diff --git a/kekkonen.scm b/kekkonen.scm index 6519271..ea86e0d 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -11,6 +11,8 @@ (import (chicken file)) (import breadline) (import ncurses) +(import util) +(import lisp) (define (lift fn parser) (bind parser (compose result fn))) @@ -19,18 +21,6 @@ (satisfies (lambda (y) (not (eqv? x y))))) -(define (curry fn a) - (lambda (b) - (fn a b))) - -(define (applied fn) - (curry apply fn)) - -(define-syntax thunk - (syntax-rules () - ((_ exp ...) - (lambda () exp ...)))) - (define parse-whitespace (one-or-more (is #\space))) @@ -319,111 +309,6 @@ (cons (get-container source) (get-contents (get-container source))) (error "Tried to determine visible objects for object without a container.")))) -(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 - (show "test function called"))) - (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 ((ea (eval a)) - (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)) - (cons args (cons 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) (compose lisp-exit (curry cons #f))))))) - (define (print-room-description room) (newline) (display (set-text '(bold) (get-name room))) diff --git a/lisp.scm b/lisp.scm new file mode 100644 index 0000000..6db6d33 --- /dev/null +++ b/lisp.scm @@ -0,0 +1,111 @@ +(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)))))))) diff --git a/util.scm b/util.scm new file mode 100644 index 0000000..c35ea03 --- /dev/null +++ b/util.scm @@ -0,0 +1,14 @@ +(module util (curry applied thunk) + (import scheme) + + (define (curry fn a) + (lambda (b) + (fn a b))) + + (define (applied fn) + (curry apply fn)) + + (define-syntax thunk + (syntax-rules () + ((_ exp ...) + (lambda () exp ...)))))