|
- (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)))
- (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 body))
-
- (call/cc (lambda (lisp-exit)
- (cons #t (lisp body (list (list)) (compose lisp-exit (curry cons #f))))))))
|