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
(loop (cdr ln)))))))
(define (lisp body environments exit)
(define (run-lisp body)
(define (lisp body environments lisp-exit)
(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)
(cond ((procedure? function)
@ -341,15 +343,15 @@
(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"))))
(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 (exit "Unknown value type in evaluation."))))
(else (lisp-exit "Unknown value type in evaluation."))))
(define (bind name value)
(set! environments (cons (let loop ((environment (car environments)))
@ -360,62 +362,61 @@
(cons (car environment) (loop (cdr environment))))))
(cdr environments))))
(lisp-eval body))
(define lisp-builtins
(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")))))
((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)
(_ (exit "malformed quote expression")))))
(_ (lisp-exit "malformed quote expression")))))
(cons . ,(lambda function-args
(match function-args
((a b) (cons a b))
(_ (exit "malformed cons expression")))))
(_ (lisp-exit "malformed cons expression")))))
(car . ,(lambda function-args
(match function-args
((a) (if (atom? a)
(exit "tried to take car of atom")
(lisp-exit "tried to take car of atom")
(car a)))
(_ (exit "malformed car expression")))))
(_ (lisp-exit "malformed car expression")))))
(cdr . ,(lambda function-args
(match function-args
((a) (if (atom? a)
(exit "tried to take cdr of atom")
(lisp-exit "tried to take cdr of atom")
(cdr a)))
(_ (exit "malformed cdr expression")))))
(_ (lisp-exit "malformed cdr expression")))))
(atom . ,(lambda function-args
(match function-args
((a) (atom? a))
(_ (exit "malformed atom expression")))))
(_ (lisp-exit "malformed atom expression")))))
(eq . ,(lambda function-args
(match function-args
((a b) (equal? a b))
(_ (exit "malformed eval expression")))))
(_ (lisp-exit "malformed eq 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")))))
(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))
(exit "malformed lambda expression"))
(_ (exit "malformed lambda expression"))))))))
(lisp-exit "malformed lambda expression"))
(_ (lisp-exit "malformed lambda expression"))))))))
(define (run-lisp body)
(call/cc (lambda (exit)
(cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f)))))))
(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)