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

fully working meta-circular evaluator

Browse Source
This commit is contained in:
Victor Fors 2021-10-31 12:39:09 +01:00
parent 541812a5b8
commit 36ea1eec53
1 changed files with 55 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
kekkonen.scm
View File

@ -10,6 +10,7 @@
(import ansi-escape-sequences)
(import (chicken file))
(import breadline)
(import ncurses)
(define (lift fn parser)
(bind parser (compose result fn)))
@ -258,7 +259,7 @@
(define (set-hidden object value)
(database-set object 'hidden value))
(define (get-hidden object)
(database-get object 'hidden #f))
@ -328,15 +329,27 @@
(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 (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)))
@ -344,66 +357,61 @@
(list (cons name value))
(if (eq? name (caar environment))
(cons (cons name value) (cdr environment))
(loop (cdr environment)))))
(cons (car 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")))))
(lisp-eval body))
(define lisp-builtins
`((test . ,(lambda (function-args)
`((test . ,(lambda function-args
(show "test function called")))
(if . ,(lambda (function-args)
(if . ,(lambda function-args
(match function-args
((e x y) (if (lisp-eval e)
(lisp-eval x)
(lisp-eval y)))
((e x y) (if e
x
y))
(_ (exit "malformed if expression")))))
(quote . ,(lambda (function-args)
(quote . ,(lambda function-args
(match function-args
((v) v)
(_ (exit "malformed quote expression")))))
(cons . ,(lambda (function-args)
(cons . ,(lambda function-args
(match function-args
((a b) (cons (eval a) (eval b)))
((a b) (cons a b))
(_ (exit "malformed cons expression")))))
(car . ,(lambda (function-args)
(car . ,(lambda function-args
(match function-args
((a) (let ((ae (eval a)))
(if (atom? ae)
(exit "tried to take car of atom")
(car (eval a)))))
((a) (if (atom? a)
(exit "tried to take car of atom")
(car a)))
(_ (exit "malformed car expression")))))
(cdr . ,(lambda (function-args)
(cdr . ,(lambda function-args
(match function-args
((a) (cdr (eval a))))))
(atom . ,(lambda (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? (eval a)))
((a) (atom? a))
(_ (exit "malformed atom expression")))))
(eq . ,(lambda (function-args)
(eq . ,(lambda function-args
(match function-args
((a b) (equal? (eval a) (eval b)))
((a b) (equal? a b))
(_ (exit "malformed eval expression")))))
(set . ,(lambda (function-args)
(set . ,(lambda function-args
(match function-args
((a b) (if (symbol? a)
(bind a b))))))
(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")))))))
(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)