114 lines
3.8 KiB
Scheme
114 lines
3.8 KiB
Scheme
(module lisp (run-lisp)
|
|
(import scheme)
|
|
(import chicken.base)
|
|
(import matchable)
|
|
(import srfi-1)
|
|
(import util)
|
|
|
|
(define (any-or fn ln thunk)
|
|
(let loop ((ln ln))
|
|
(if (null? ln)
|
|
(thunk)
|
|
(let ((result (fn (car ln))))
|
|
(if result
|
|
result
|
|
(loop (cdr ln)))))))
|
|
|
|
(define (run-lisp body)
|
|
|
|
(define (lisp body environments lisp-exit)
|
|
|
|
(define (reference symbol)
|
|
(cdr (any-or (curry assoc symbol) (cons lisp-builtins environments) (thunk (lisp-exit (string-append "Undefined reference: " (symbol->string symbol)))))))
|
|
|
|
(define (lisp-apply function args)
|
|
(cond ((procedure? function)
|
|
(apply function args))
|
|
((list? function)
|
|
(let ((function-arguments (car function))
|
|
(function-body (cdr function)))
|
|
(lisp function-body (cons (if (= (length function-arguments) (length args))
|
|
(map cons function-arguments args)
|
|
(lisp-exit "Wrong number of arguments to function")) environments) lisp-exit)))
|
|
(else (lisp-exit "attempt to call atom"))))
|
|
|
|
(define (lisp-eval body)
|
|
(cond ((symbol? body) (reference body))
|
|
((atom? body) body)
|
|
((list? body) (lisp-apply (lisp-eval (car body)) (cdr body)))
|
|
(else (lisp-exit "Unknown value type in evaluation."))))
|
|
|
|
(define (bind name value)
|
|
(set! environments (cons (let loop ((environment (car environments)))
|
|
(if (null? environment)
|
|
(list (cons name value))
|
|
(if (eq? name (caar environment))
|
|
(cons (cons name value) (cdr environment))
|
|
(cons (car environment) (loop (cdr environment))))))
|
|
(cdr environments))))
|
|
|
|
(define lisp-builtins
|
|
`((test . ,(lambda function-args
|
|
(display "test function called")
|
|
(newline)))
|
|
(begin . ,(lambda function-args
|
|
(mapn lisp-eval function-args)))
|
|
(if . ,(lambda function-args
|
|
(match function-args
|
|
((e x y) (if (lisp-eval e)
|
|
(lisp-eval x)
|
|
(lisp-eval y)))
|
|
(_ (lisp-exit "malformed if expression")))))
|
|
(quote . ,(lambda function-args
|
|
(match function-args
|
|
((v) v)
|
|
(_ (lisp-exit "malformed quote expression")))))
|
|
(cons . ,(lambda function-args
|
|
(match function-args
|
|
((a b) (cons (lisp-eval a) (lisp-eval b)))
|
|
(_ (lisp-exit "malformed cons expression")))))
|
|
(car . ,(lambda function-args
|
|
(match function-args
|
|
((a) (let ((e (lisp-eval a)))
|
|
(if (atom? e)
|
|
(lisp-exit "tried to take car of atom")
|
|
(car e))))
|
|
(_ (lisp-exit "malformed car expression")))))
|
|
(cdr . ,(lambda function-args
|
|
(match function-args
|
|
((a) (let ((e (lisp-eval a)))
|
|
(if (atom? e)
|
|
(lisp-exit "tried to take cdr of atom")
|
|
(cdr e))))
|
|
(_ (lisp-exit "malformed cdr expression")))))
|
|
(atom . ,(lambda function-args
|
|
(match function-args
|
|
((a) (let ((e (lisp-eval a)))
|
|
(atom? e)))
|
|
(_ (lisp-exit "malformed atom expression")))))
|
|
(eq . ,(lambda function-args
|
|
(match function-args
|
|
((a b) (let ((ea (eval a))
|
|
(eb (eval b)))
|
|
(equal? ea eb)))
|
|
(_ (lisp-exit "malformed eq expression")))))
|
|
(set . ,(lambda function-args
|
|
(match function-args
|
|
((a b) (let ((eb (eval b)))
|
|
(if (symbol? a)
|
|
(bind a b)
|
|
(lisp-exit "tried to bind to non-symbol"))))
|
|
(_ (lisp-exit "malformed set expression")))))
|
|
(lambda . ,(lambda function-args
|
|
(match function-args
|
|
((args exp . exps)
|
|
(if (and (list? args) (every symbol? args))
|
|
(append (list args exp) exps)
|
|
(lisp-exit "malformed lambda expression")))
|
|
(_ (lisp-exit "malformed lambda expression")))))))
|
|
|
|
(lisp-eval (cons 'begin body)))
|
|
|
|
(call/cc (lambda (lisp-exit)
|
|
(cons #t (lisp body (list (list)) (compose lisp-exit (curry cons #f))))))))
|