nya
This commit is contained in:
parent
36ea1eec53
commit
767542e4b1
175
kekkonen.scm
175
kekkonen.scm
@ -328,94 +328,95 @@
|
|||||||
result
|
result
|
||||||
(loop (cdr ln)))))))
|
(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)
|
(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)
|
(define (print-room-description room)
|
||||||
(newline)
|
(newline)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user