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

175
kekkonen.scm
View File

@ -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)