- Added skeleton of an interpreter that accepts the same language as
the compiler (i.e., the one produced by psyntax).
This commit is contained in:
Abdulaziz Ghuloum
parent
7002046c8e
commit
1a738c2a8d
|
|
@ -0,0 +1,204 @@
|
|||
|
||||
(import (ikarus) (match))
|
||||
|
||||
(define (make-annotated-procedure ann proc)
|
||||
(import (ikarus system $codes))
|
||||
($make-annotated-procedure ann proc))
|
||||
|
||||
|
||||
(define (compile-expr expr env)
|
||||
(define who 'compile-expr)
|
||||
(define (do-letrec lhs* rhs* body env)
|
||||
(let-values ([(env n) (extend-env lhs* env)])
|
||||
(let ([rhs* (map (lambda (x) (compile-expr x env)) rhs*)]
|
||||
[body (compile-expr body env)])
|
||||
(lambda (env)
|
||||
(let ([vec (make-vector n)])
|
||||
(let ([env (cons vec env)])
|
||||
(let f ([i 0] [rhs* rhs*])
|
||||
(if (null? rhs*)
|
||||
(body env)
|
||||
(begin
|
||||
(vector-set! vec i ((car rhs*) env))
|
||||
(f (+ i 1) (cdr rhs*)))))))))))
|
||||
(define (do-library-letrec lhs* loc* rhs* body env)
|
||||
(let-values ([(env n) (extend-env lhs* env)])
|
||||
(let ([rhs* (map (lambda (x) (compile-expr x env)) rhs*)]
|
||||
[body (compile-expr body env)])
|
||||
(lambda (env)
|
||||
(let ([vec (make-vector n)])
|
||||
(let ([env (cons vec env)])
|
||||
(let f ([i 0] [rhs* rhs*] [loc* loc*])
|
||||
(if (null? rhs*)
|
||||
(body env)
|
||||
(let ([v ((car rhs*) env)])
|
||||
(vector-set! vec i v)
|
||||
(global-set! (car loc*) v)
|
||||
(f (+ i 1) (cdr rhs*) (cdr loc*)))))))))))
|
||||
(define (lexical-set! env i j v)
|
||||
(vector-set! (list-ref env i) j v))
|
||||
(define (lexical-ref env i j)
|
||||
(vector-ref (list-ref env i) j))
|
||||
(define (global-set! loc v)
|
||||
(set-symbol-value! loc v))
|
||||
(define (global-ref loc)
|
||||
(top-level-value loc))
|
||||
(define (extend-env ls env)
|
||||
(define (properize x)
|
||||
(cond
|
||||
[(null? x) '()]
|
||||
[(pair? x) (cons (car x) (properize (cdr x)))]
|
||||
[else (list x)]))
|
||||
(let ([v (list->vector (properize ls))])
|
||||
(values (cons v env) (vector-length v))))
|
||||
(define (lookup x env)
|
||||
(let f ([i 0] [env env])
|
||||
(cond
|
||||
[(null? env) `(global ,x)]
|
||||
[else
|
||||
(let g ([j 0] [rib (car env)])
|
||||
(cond
|
||||
[(= j (vector-length rib))
|
||||
(f (+ i 1) (cdr env))]
|
||||
[(eq? x (vector-ref rib j)) `(lexical ,i ,j)]
|
||||
[else (g (+ j 1) rib)]))])))
|
||||
(define (compile-case-lambda ae fml* expr* env k)
|
||||
(define (compile-clause fmls expr k)
|
||||
(cond
|
||||
[(list? fmls)
|
||||
(let-values ([(env n) (extend-env fmls env)])
|
||||
(let ([expr (compile-expr expr env)])
|
||||
(lambda (env args argcount)
|
||||
(if (= n argcount)
|
||||
(expr (cons (list->vector args) env))
|
||||
(k env args argcount)))))]
|
||||
[else
|
||||
(let-values ([(env n) (extend-env fmls env)])
|
||||
(let ([expr (compile-expr expr env)])
|
||||
(lambda (env args argcount)
|
||||
(if (>= argcount n)
|
||||
(let ([vec (make-vector n)])
|
||||
(let f ([ls args] [i 0])
|
||||
(cond
|
||||
[(= i (- n 1))
|
||||
(vector-set! vec i ls)]
|
||||
[else
|
||||
(vector-set! vec i (car ls))
|
||||
(f (cdr ls) (+ i 1))]))
|
||||
(expr (cons vec env)))
|
||||
(k env args argcount)))))]))
|
||||
(let ([proc
|
||||
(let f ([fml* fml*] [expr* expr*])
|
||||
(cond
|
||||
[(null? fml*) k]
|
||||
[else
|
||||
(compile-clause (car fml*) (car expr*)
|
||||
(f (cdr fml*) (cdr expr*)))]))])
|
||||
(lambda (env)
|
||||
(make-annotated-procedure
|
||||
(cons #f
|
||||
(if (annotation? ae)
|
||||
(annotation-source ae)
|
||||
'#f))
|
||||
(lambda args
|
||||
(proc env args (length args)))))))
|
||||
(match expr
|
||||
[(quote ,x) (lambda (env) x)]
|
||||
[,var (guard (gensym? var))
|
||||
(let ([var (lookup var env)])
|
||||
(match var
|
||||
[(lexical ,i ,j)
|
||||
(lambda (env)
|
||||
(lexical-ref env i j))]
|
||||
[(global ,loc)
|
||||
(lambda (env)
|
||||
(global-ref loc))]
|
||||
[,_ (die who "invalid variable" var)]))]
|
||||
[(set! ,lhs ,[rhs])
|
||||
(let ([lhs (lookup lhs env)])
|
||||
(match lhs
|
||||
[(lexical ,i ,j)
|
||||
(lambda (env)
|
||||
(lexical-set! env i j (rhs env)))]
|
||||
[(global ,loc)
|
||||
(lambda (env)
|
||||
(global-set! loc (rhs env)))]
|
||||
[,_ (die who "invalid set! target" lhs)]))]
|
||||
[(if ,[e0] ,[e1] ,[e2])
|
||||
(lambda (env)
|
||||
(if (e0 env) (e1 env) (e2 env)))]
|
||||
[(begin ,[e] ,[e*] ...)
|
||||
(let ([e* (cons e e*)])
|
||||
(lambda (env)
|
||||
(for-each (lambda (e) (e env)) e*)))]
|
||||
[(annotated-case-lambda ,ae [,fml* ,expr*] ...)
|
||||
(compile-case-lambda ae fml* expr* env
|
||||
(lambda (env args argcount)
|
||||
(assertion-violation 'apply
|
||||
"incorrect number of arguments"
|
||||
args)))]
|
||||
[(case-lambda [,fml* ,expr*] ...)
|
||||
(compile-case-lambda #f fml* expr* env
|
||||
(lambda (env args argcount)
|
||||
(assertion-violation 'apply
|
||||
"incorrect number of arguments"
|
||||
args)))]
|
||||
[(lambda ,fmls ,body)
|
||||
(compile-expr `(case-lambda [,fmls ,body]) env)]
|
||||
[(letrec ([,lhs* ,rhs*] ...) ,body)
|
||||
(do-letrec lhs* rhs* body env)]
|
||||
[(letrec* ([,lhs* ,rhs*] ...) ,body)
|
||||
(do-letrec lhs* rhs* body env)]
|
||||
[(library-letrec* ([,lhs* ,loc* ,rhs*] ...) ,body)
|
||||
(do-library-letrec lhs* loc* rhs* body env)]
|
||||
[(primitive ,x)
|
||||
(let ([v (system-value x)])
|
||||
(lambda (env) v))]
|
||||
[(,[e] ,[e*] ...)
|
||||
(lambda (env)
|
||||
(apply (e env) (map (lambda (e) (e env)) e*)))]
|
||||
[,x (die who "invalid expression" x)]))
|
||||
|
||||
|
||||
(parameterize ([current-core-eval
|
||||
(lambda (expr)
|
||||
;(display "=================\n")
|
||||
;(pretty-print expr)
|
||||
;(display "=================\n")
|
||||
(let ([proc (compile-expr expr '())])
|
||||
(proc '())))])
|
||||
(display "Ikarus Interpreter\n\n")
|
||||
(new-cafe))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#!eof
|
||||
|
||||
(define-struct cell (prev next content))
|
||||
|
||||
(define (make-ring n f)
|
||||
(cond
|
||||
[(= n 1)
|
||||
(let ([cell (make-cell #f #f (f))])
|
||||
(set-cell-prev! cell cell)
|
||||
(set-cell-next! cell cell)
|
||||
cell)]
|
||||
[else
|
||||
(let ([ring (make-ring (- n 1) f)])
|
||||
(let ([prev (cell-prev ring)]
|
||||
[next (cell-next ring)])
|
||||
(let ([cell (make-cell ring next (f))])
|
||||
(set-cell-next! prev cell)
|
||||
(set-cell-prev! ring cell)
|
||||
cell)))]))
|
||||
|
||||
(define (make-double-ring n m)
|
||||
(make-ring n (lambda () (make-ring m (lambda () #f)))))
|
||||
|
||||
(print-graph #t)
|
||||
|
||||
;(write (make-double-rib 5 5))
|
||||
(write (make-ring 10 (lambda () #f)))
|
||||
(newline)
|
||||
|
|
@ -1 +1 @@
|
|||
1771
|
||||
1772
|
||||
|
|
|
|||
Loading…
Reference in New Issue