whiteline/kekkonen
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

nya

Browse Source
This commit is contained in:
Victor Fors 2021-11-12 17:22:25 +01:00
parent 36ea1eec53
commit 767542e4b1
1 changed files with 88 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
kekkonen.scm
View File

@ -328,10 +328,12 @@
result result
(loop (cdr ln))))))) (loop (cdr ln)))))))
(define (lisp body environments exit) (define (run-lisp body)
(define (lisp body environments lisp-exit)
(define (reference symbol) (define (reference symbol)
(cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string 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) (define (lisp-apply function args)
(cond ((procedure? function) (cond ((procedure? function)
@ -341,15 +343,15 @@
(function-body (cddr function))) (function-body (cddr function)))
(lisp function-body (cons (if (= (length function-arguments) (length argument-values)) (lisp function-body (cons (if (= (length function-arguments) (length argument-values))
(map cons function-arguments args) (map cons function-arguments args)
(exit "Wrong number of arguments to function")) environments) exit))) (lisp-exit "Wrong number of arguments to function")) environments) lisp-exit)))
(else (exit "attempt to call atom")))) (else (lisp-exit "attempt to call atom"))))
(define (lisp-eval body) (define (lisp-eval body)
(cond ((symbol? body) (reference body)) (cond ((symbol? body) (reference body))
((atom? body) body) ((atom? body) body)
((list? body) (let ((ln (map lisp-eval body))) ((list? body) (let ((ln (map lisp-eval body)))
(lisp-apply (car ln) (cdr ln)))) (lisp-apply (car ln) (cdr ln))))
(else (exit "Unknown value type in evaluation.")))) (else (lisp-exit "Unknown value type in evaluation."))))
(define (bind name value) (define (bind name value)
(set! environments (cons (let loop ((environment (car environments))) (set! environments (cons (let loop ((environment (car environments)))
@ -360,62 +362,61 @@
(cons (car environment) (loop (cdr environment)))))) (cons (car environment) (loop (cdr environment))))))
(cdr environments)))) (cdr environments))))
(lisp-eval body)) (define lisp-builtins
(define lisp-builtins
`((test . ,(lambda function-args `((test . ,(lambda function-args
(show "test function called"))) (show "test function called")))
(if . ,(lambda function-args (if . ,(lambda function-args
(match function-args (match function-args
((e x y) (if e ((e x y) (if (lisp-eval e)
x (lisp-eval x)
y)) (lisp-eval y)))
(_ (exit "malformed if expression"))))) (_ (lisp-exit "malformed if expression")))))
(quote . ,(lambda function-args (quote . ,(lambda function-args
(match function-args (match function-args
((v) v) ((v) v)
(_ (exit "malformed quote expression"))))) (_ (lisp-exit "malformed quote expression")))))
(cons . ,(lambda function-args (cons . ,(lambda function-args
(match function-args (match function-args
((a b) (cons a b)) ((a b) (cons a b))
(_ (exit "malformed cons expression"))))) (_ (lisp-exit "malformed cons expression")))))
(car . ,(lambda function-args (car . ,(lambda function-args
(match function-args (match function-args
((a) (if (atom? a) ((a) (if (atom? a)
(exit "tried to take car of atom") (lisp-exit "tried to take car of atom")
(car a))) (car a)))
(_ (exit "malformed car expression"))))) (_ (lisp-exit "malformed car expression")))))
(cdr . ,(lambda function-args (cdr . ,(lambda function-args
(match function-args (match function-args
((a) (if (atom? a) ((a) (if (atom? a)
(exit "tried to take cdr of atom") (lisp-exit "tried to take cdr of atom")
(cdr a))) (cdr a)))
(_ (exit "malformed cdr expression"))))) (_ (lisp-exit "malformed cdr expression")))))
(atom . ,(lambda function-args (atom . ,(lambda function-args
(match function-args (match function-args
((a) (atom? a)) ((a) (atom? a))
(_ (exit "malformed atom expression"))))) (_ (lisp-exit "malformed atom expression")))))
(eq . ,(lambda function-args (eq . ,(lambda function-args
(match function-args (match function-args
((a b) (equal? a b)) ((a b) (equal? a b))
(_ (exit "malformed eval expression"))))) (_ (lisp-exit "malformed eq expression")))))
(set . ,(lambda function-args (set . ,(lambda function-args
(match function-args (match function-args
((a b) (if (symbol? a) ((a b) (if (symbol? a)
(bind a b) (bind a b)
(exit "tried to bind to non-symbol"))) (lisp-exit "tried to bind to non-symbol")))
(_ (exit "malformed set expression"))))) (_ (lisp-exit "malformed set expression")))))
(lambda . ,(lambda function-args (lambda . ,(lambda function-args
(match function-args (match function-args
((args exp . exps) ((args exp . exps)
(if (and (list? args) (every symbol? args)) (if (and (list? args) (every symbol? args))
(cons args (cons exp exps)) (cons args (cons exp exps))
(exit "malformed lambda expression")) (lisp-exit "malformed lambda expression"))
(_ (exit "malformed lambda expression")))))))) (_ (lisp-exit "malformed lambda expression"))))))))
(define (run-lisp body) (lisp-eval body))
(call/cc (lambda (exit)
(cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f))))))) (call/cc (lambda (lisp-exit)
(cons #t (lisp body (list) (compose lisp-exit (curry cons #f)))))))
(define (print-room-description room) (define (print-room-description room)
(newline) (newline)