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

nya

Browse Source
This commit is contained in:
Victor Fors 2021-09-19 23:46:14 +02:00
parent ae8603b120
commit 541812a5b8
1 changed files with 31 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
kekkonen.scm
View File

@ -327,6 +327,37 @@
result result
(loop (cdr ln))))))) (loop (cdr ln)))))))
(define (lisp body environments exit)
(define (lisp-eval body)
(cond ((atom? body) body)
((symbol? body) (reference body))
((list? body) (let ((ln (map lisp-eval body)))
(apply (car ln) (cdr ln))))
(else (exit "Unknown value type in evaluation."))))
(define (reference symbol)
(cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string symbol))))))
(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))
(loop (cdr environment)))))
(cdr environments))))
(define (lisp-apply function args)
(cond ((function? function)
(apply function args))
((list? function)
(let ((function-arguments (car function))
(function-body (cddr function)))
(lisp function-body (cons (if (= (length function-argumentsq) (length argument-values))
(map cons function-arguments args)
(exit "Wrong number of arguments to function")) environments) exit)))
(_ (exit "attempt to call atom")))))
(define lisp-builtins (define lisp-builtins
`((test . ,(lambda (function-args) `((test . ,(lambda (function-args)
(show "test function called"))) (show "test function called")))
@ -374,39 +405,6 @@
(exit "malformed lambda expression")) (exit "malformed lambda expression"))
(_ (exit "malformed lambda expression"))))))) (_ (exit "malformed lambda expression")))))))
(define (lisp body environments exit)
(define (lisp-eval body)
(cond ((atom? body) body)
((symbol? body) (reference body))
((list? body) (let ((ln (map lisp-eval body)))
(apply (car ln) (cdr ln))))
(else (exit "Unknown value type in evaluation."))))
(define (reference symbol)
(cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string symbol))))))
(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))
(loop (cdr environment)))))
(cdr environments))))
(define (lisp-apply function args)
(if (function? function)
(apply function args)
(case function-name
(else (let ((function (reference function-name environments)))
(let ((function-arguments (car function))
(argument-values (cdr body))
(function-body (cddr function)))
(lisp function-body (cons (if (= (length function-arguments) (length argument-values))
(map cons function-arguments (map eval argument-values))
(exit "Wrong number of arguments to function")) environments exit))))))
(exit "attempt to call atom")))))
(define (run-lisp body) (define (run-lisp body)
(call/cc (lambda (exit) (call/cc (lambda (exit)
(cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f))))))) (cons #t (lisp body (list lisp-builtins) (compose exit (curry cons #f)))))))