From 767542e4b18f2cf1e4c4ae9a40818835b6ad82bf Mon Sep 17 00:00:00 2001 From: Victor Fors Date: Fri, 12 Nov 2021 17:22:25 +0100 Subject: [PATCH] nya --- kekkonen.scm | 175 ++++++++++++++++++++++++++++++----------------------------- 1 file changed, 88 insertions(+), 87 deletions(-) diff --git a/kekkonen.scm b/kekkonen.scm index 547a6f4..b26d2a4 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -328,94 +328,95 @@ result (loop (cdr ln))))))) -(define (lisp body environments exit) - - (define (reference symbol) - (cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string symbol)))))) - - (define (lisp-apply function args) - (cond ((procedure? function) - (apply function args)) - ((list? function) - (let ((function-arguments (cadr function)) - (function-body (cddr function))) - (lisp function-body (cons (if (= (length function-arguments) (length argument-values)) - (map cons function-arguments args) - (exit "Wrong number of arguments to function")) environments) exit))) - (else (exit "attempt to call atom")))) - - (define (lisp-eval body) - (cond ((symbol? body) (reference body)) - ((atom? body) body) - ((list? body) (let ((ln (map lisp-eval body))) - (lisp-apply (car ln) (cdr ln)))) - (else (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)))) - - (lisp-eval body)) - -(define lisp-builtins - `((test . ,(lambda function-args - (show "test function called"))) - (if . ,(lambda function-args - (match function-args - ((e x y) (if e - x - y)) - (_ (exit "malformed if expression"))))) - (quote . ,(lambda function-args - (match function-args - ((v) v) - (_ (exit "malformed quote expression"))))) - (cons . ,(lambda function-args - (match function-args - ((a b) (cons a b)) - (_ (exit "malformed cons expression"))))) - (car . ,(lambda function-args - (match function-args - ((a) (if (atom? a) - (exit "tried to take car of atom") - (car a))) - (_ (exit "malformed car expression"))))) - (cdr . ,(lambda function-args - (match function-args - ((a) (if (atom? a) - (exit "tried to take cdr of atom") - (cdr a))) - (_ (exit "malformed cdr expression"))))) - (atom . ,(lambda function-args - (match function-args - ((a) (atom? a)) - (_ (exit "malformed atom expression"))))) - (eq . ,(lambda function-args - (match function-args - ((a b) (equal? a b)) - (_ (exit "malformed eval expression"))))) - (set . ,(lambda function-args - (match function-args - ((a b) (if (symbol? a) - (bind a b) - (exit "tried to bind to non-symbol"))) - (_ (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)) - (exit "malformed lambda expression")) - (_ (exit "malformed lambda expression")))))))) - (define (run-lisp body) - (call/cc (lambda (exit) - (cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f))))))) + + (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 (cadr function)) + (function-body (cddr function))) + (lisp function-body (cons (if (= (length function-arguments) (length argument-values)) + (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) (let ((ln (map lisp-eval body))) + (lisp-apply (car ln) (cdr ln)))) + (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 a b)) + (_ (lisp-exit "malformed cons expression"))))) + (car . ,(lambda function-args + (match function-args + ((a) (if (atom? a) + (lisp-exit "tried to take car of atom") + (car a))) + (_ (lisp-exit "malformed car expression"))))) + (cdr . ,(lambda function-args + (match function-args + ((a) (if (atom? a) + (lisp-exit "tried to take cdr of atom") + (cdr a))) + (_ (lisp-exit "malformed cdr expression"))))) + (atom . ,(lambda function-args + (match function-args + ((a) (atom? a)) + (_ (lisp-exit "malformed atom expression"))))) + (eq . ,(lambda function-args + (match function-args + ((a b) (equal? a b)) + (_ (lisp-exit "malformed eq expression"))))) + (set . ,(lambda function-args + (match function-args + ((a 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)