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

88
kekkonen.scm
View File

@ -10,6 +10,7 @@
(import ansi-escape-sequences) (import ansi-escape-sequences)
(import (chicken file)) (import (chicken file))
(import breadline) (import breadline)
(import ncurses)
(define (lift fn parser) (define (lift fn parser)
(bind parser (compose result fn))) (bind parser (compose result fn)))
@ -328,82 +329,89 @@
(loop (cdr ln))))))) (loop (cdr ln)))))))
(define (lisp body environments exit) (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) (define (reference symbol)
(cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string 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) (define (bind name value)
(set! environments (cons (let loop ((environment (car environments))) (set! environments (cons (let loop ((environment (car environments)))
(if (null? environment) (if (null? environment)
(list (cons name value)) (list (cons name value))
(if (eq? name (caar environment)) (if (eq? name (caar environment))
(cons (cons name value) (cdr environment)) (cons (cons name value) (cdr environment))
(loop (cdr environment))))) (cons (car environment) (loop (cdr environment))))))
(cdr environments)))) (cdr environments))))
(define (lisp-apply function args) (lisp-eval body))
(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")))
(if . ,(lambda (function-args) (if . ,(lambda function-args
(match function-args (match function-args
((e x y) (if (lisp-eval e) ((e x y) (if e
(lisp-eval x) x
(lisp-eval y))) y))
(_ (exit "malformed if expression"))))) (_ (exit "malformed if expression")))))
(quote . ,(lambda (function-args) (quote . ,(lambda function-args
(match function-args (match function-args
((v) v) ((v) v)
(_ (exit "malformed quote expression"))))) (_ (exit "malformed quote expression")))))
(cons . ,(lambda (function-args) (cons . ,(lambda function-args
(match function-args (match function-args
((a b) (cons (eval a) (eval b))) ((a b) (cons a b))
(_ (exit "malformed cons expression"))))) (_ (exit "malformed cons expression")))))
(car . ,(lambda (function-args) (car . ,(lambda function-args
(match function-args (match function-args
((a) (let ((ae (eval a))) ((a) (if (atom? a)
(if (atom? ae)
(exit "tried to take car of atom") (exit "tried to take car of atom")
(car (eval a))))) (car a)))
(_ (exit "malformed car expression"))))) (_ (exit "malformed car expression")))))
(cdr . ,(lambda (function-args) (cdr . ,(lambda function-args
(match function-args (match function-args
((a) (cdr (eval a)))))) ((a) (if (atom? a)
(atom . ,(lambda (function-args) (exit "tried to take cdr of atom")
(cdr a)))
(_ (exit "malformed cdr expression")))))
(atom . ,(lambda function-args
(match function-args (match function-args
((a) (atom? (eval a))) ((a) (atom? a))
(_ (exit "malformed atom expression"))))) (_ (exit "malformed atom expression")))))
(eq . ,(lambda (function-args) (eq . ,(lambda function-args
(match function-args (match function-args
((a b) (equal? (eval a) (eval b))) ((a b) (equal? a b))
(_ (exit "malformed eval expression"))))) (_ (exit "malformed eval expression")))))
(set . ,(lambda (function-args) (set . ,(lambda function-args
(match function-args (match function-args
((a b) (if (symbol? a) ((a b) (if (symbol? a)
(bind a b)))))) (bind a b)
(lambda . ,(lambda (function-args) (exit "tried to bind to non-symbol")))
match function-args (_ (exit "malformed set expression")))))
(lambda . ,(lambda function-args
(match function-args
((args exp . exps) ((args exp . exps)
(if (and (list? args) (every symbol? args)) (if (and (list? args) (every symbol? args))
(cons args (cons exp exps)) (cons args (cons exp exps))
(exit "malformed lambda expression")) (exit "malformed lambda expression"))
(_ (exit "malformed lambda expression"))))))) (_ (exit "malformed lambda expression"))))))))
(define (run-lisp body) (define (run-lisp body)
(call/cc (lambda (exit) (call/cc (lambda (exit)