103 lines
3.2 KiB
Scheme
103 lines
3.2 KiB
Scheme
|
|
||
|
|
(import (ikarus) (ikarus.debugger))
|
||
|
|
|
||
|
|
(define (operator? x)
|
||
|
|
(and (pair? x)
|
||
|
|
(eq? (car x) 'primitive)
|
||
|
|
(guard (con [(assertion-violation? con) #t])
|
||
|
|
(system-value (cadr x))
|
||
|
|
#f)))
|
||
|
|
|
||
|
|
(define (get-src/expr ae)
|
||
|
|
(if (annotation? ae)
|
||
|
|
(cons (annotation-source ae) (annotation-stripped ae))
|
||
|
|
(cons #f (syntax->datum ae))))
|
||
|
|
|
||
|
|
(define (add-debug-calls expr)
|
||
|
|
(define who 'add-debug-calls)
|
||
|
|
(define (direct-call? op rands)
|
||
|
|
(define n (length rands))
|
||
|
|
(define (test cls*)
|
||
|
|
(and (pair? cls*)
|
||
|
|
(or
|
||
|
|
(let ([fmls (caar cls*)])
|
||
|
|
(and (list? fmls) (= (length fmls) n)))
|
||
|
|
(test (cdr cls*)))))
|
||
|
|
(and (pair? op)
|
||
|
|
(case (car op)
|
||
|
|
[(lambda) (test (list (cdr op)))]
|
||
|
|
[(case-lambda) (test (cdr op))]
|
||
|
|
[(annotated-case-lambda) (test (cddr op))]
|
||
|
|
[else #f])))
|
||
|
|
(define (E-call src/expr op rands)
|
||
|
|
(cond
|
||
|
|
[(or (operator? op) (direct-call? op rands))
|
||
|
|
`(,(E op) ,@(map E rands))]
|
||
|
|
[else
|
||
|
|
`(',debug-call ',src/expr ,(E op) ,@(map E rands))]))
|
||
|
|
(define (E expr)
|
||
|
|
(cond
|
||
|
|
[(symbol? expr) expr]
|
||
|
|
[(and (pair? expr) (list? expr))
|
||
|
|
(let ([a (car expr)] [d (cdr expr)])
|
||
|
|
(case a
|
||
|
|
[(quote) expr]
|
||
|
|
[(primitive) expr]
|
||
|
|
[(set!) `(set! ,(car d) ,(E (cadr d)))]
|
||
|
|
[(if) `(if ,(E (car d)) ,(E (cadr d)) ,(E (caddr d)))]
|
||
|
|
[(begin) (cons 'begin (map E d))]
|
||
|
|
[(lambda) (list 'lambda (car d) (E (cadr d)))]
|
||
|
|
[(case-lambda)
|
||
|
|
(cons 'case-lambda
|
||
|
|
(map (lambda (x) (list (car x) (E (cadr x)))) d))]
|
||
|
|
[(annotated-case-lambda)
|
||
|
|
(cons* 'annotated-case-lambda (car d)
|
||
|
|
(map (lambda (x) (list (car x) (E (cadr x)))) (cdr d)))]
|
||
|
|
[(letrec letrec*)
|
||
|
|
(list a
|
||
|
|
(map (lambda (x) (list (car x) (E (cadr x)))) (car d))
|
||
|
|
(E (cadr d)))]
|
||
|
|
[(foreign-call)
|
||
|
|
(cons* 'foreign-call (car d) (map E (cdr d)))]
|
||
|
|
[(library-letrec*)
|
||
|
|
(list a
|
||
|
|
(map (lambda (x) (list (car x) (cadr x) (E (caddr x)))) (car d))
|
||
|
|
(E (cadr d)))]
|
||
|
|
[(annotated-call)
|
||
|
|
(E-call (get-src/expr (car d)) (cadr d) (cddr d))]
|
||
|
|
[else (E-call #f a d)]))]
|
||
|
|
[else
|
||
|
|
(die who "invalid expression" expr)]))
|
||
|
|
(E expr))
|
||
|
|
|
||
|
|
(define (start-repl)
|
||
|
|
(display "Ikarus Interpreter\n\n")
|
||
|
|
(new-cafe
|
||
|
|
(lambda (x)
|
||
|
|
(guarded-start
|
||
|
|
(lambda ()
|
||
|
|
(eval x (interaction-environment)))))))
|
||
|
|
|
||
|
|
(define (start-script script-name args)
|
||
|
|
(command-line-arguments (cons script-name args))
|
||
|
|
(guarded-start
|
||
|
|
(lambda ()
|
||
|
|
(load-r6rs-script script-name #f #t))))
|
||
|
|
|
||
|
|
(current-core-eval
|
||
|
|
(let ([ev (current-core-eval)])
|
||
|
|
(lambda (x)
|
||
|
|
(let ([x (add-debug-calls x)])
|
||
|
|
(ev x)))))
|
||
|
|
|
||
|
|
(apply
|
||
|
|
(case-lambda
|
||
|
|
[(interpreter flag script-name . rest)
|
||
|
|
(if (string=? flag "--r6rs-script")
|
||
|
|
(start-script script-name rest)
|
||
|
|
(error interpreter "invalid args" (cons* flag script-name rest)))]
|
||
|
|
[(interpreter) (start-repl)]
|
||
|
|
[(interpreter . rest)
|
||
|
|
(error interpreter "invalid args" rest)])
|
||
|
|
(command-line-arguments))
|