From c93d192c32c376705d3b0a740c81156a44e63ecb Mon Sep 17 00:00:00 2001 From: Akshay Date: Wed, 4 Nov 2020 08:53:43 +0530 Subject: add basic evaluator, environment --- environment.scm | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++ main.scm | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++ prelude/primitives.scm | 36 +++++++++++++++++++++++++ util/alist.scm | 12 +++++++++ util/table.scm | 21 +++++++++++++++ 5 files changed, 213 insertions(+) create mode 100644 environment.scm create mode 100644 main.scm create mode 100644 prelude/primitives.scm create mode 100644 util/alist.scm create mode 100644 util/table.scm diff --git a/environment.scm b/environment.scm new file mode 100644 index 0000000..2444059 --- /dev/null +++ b/environment.scm @@ -0,0 +1,72 @@ +(include "prelude/primitives.scm") + +;;; env +(define (enclosing-env environ) (cdr environ)) +(define (first-frame environ) (car environ)) +(define the-empty-env '()) +(define (empty-env? environ) (eq? environ the-empty-env)) + +;; frames +(define (make-frame variables values) + (cons variables values)) +(define frame-variables car) +(define frame-values cdr) +(define (add-binding-to-frame! var val frame) + (begin + (set-car! frame (cons var (frame-variables frame))) + (set-cdr! frame (cons val (frame-values frame))))) +(define (extend-env vars vals base-env) + (if (= (length vars) (length vals)) + (cons (make-frame vars vals) base-env) + (error "Too few or too many arguments supplied" vars vals))) + +;;; variable lookup +(define (lookup-variable-value var env) + (cond + [(empty-env? env) (error "Unbound variable" var)] + [else + (let ([f (first-frame env)]) + (let scan ([variables (frame-variables f)] + [values (frame-values f)]) + (cond + [(null? variables) + (lookup-variable-value var + (enclosing-env env))] + [(eq? var (car variables)) (car values)] + [else (scan (cdr variables) (cdr values))])))])) + +;;; environment modification +(define (set-variable-value! var val env) + (cond + [(empty-env? env) (error "Unbound variable" var)] + [else + (let ([f (first-frame env)]) + (let scan ([variables (frame-variables f)] + [values (frame-values f)]) + (cond + [(null? variables) (set-variable-value! + var + val + (enclosing-env env))] + [(eq? var (car variables)) (set-car! values val)] + [else (scan (cdr variables) (cdr values))])))])) + +(define (define-variable! var val env) + (let ([f (first-frame env)]) + (define (scan vars vals) + (cond + [(null? vars) (add-binding-to-frame! var val f)] + [(eq? var (car vars)) (set-car! vals val)] + [else (scan (cdr vars) (cdr vals))])) + (scan (frame-variables f) + (frame-values f)))) + +(define (setup-environment) + (let ([initial-env (extend-env + (primitive-names) + (primitive-objs) + the-empty-env)]) + (define-variable! 'true #t initial-env) + (define-variable! 'false #f initial-env) + initial-env)) + diff --git a/main.scm b/main.scm new file mode 100644 index 0000000..08a5a22 --- /dev/null +++ b/main.scm @@ -0,0 +1,72 @@ +(include "prelude/primitives.scm") +(include "util/table.scm") +(include "util/alist.scm") + +(define (lift-bool expr) (if expr 'true 'false)) + +(define (tagged? expr tag) + (if (pair? expr) + (eq? (car expr) tag) + #f)) + +;;; self-evaluating +(define (self-evaluating? expr) + (or (number? expr) + (string? expr) + (bool? expr))) + +(define variable? symbol?) + +;;; if-else +(define (if-else? expr) (tagged? expr 'if)) +(define (if-predicate expr) (cadr expr)) +(define (if-consequent expr) (caddr expr)) +(define (if-alternative expr) + (if (not (null? (cdddr expr))) + (cadddr expr) + 'false)) + +;;; function application +(define (function-application? expr) (pair? expr)) +(define (operator expr) (car expr)) +(define (operands expr) (cdr expr)) +(define (no-operands? expr) (null? expr)) +(define (list-of-values ls env) + (if (no-operands? ls) + '() + (let ([first (eval-expr (car ls) env)]) + (let ([rest (list-of-values (cdr ls) env)]) + (cons first rest))))) + +;;; quoted expressions +(define (quote-form? expr) (tagged? expr 'quote)) +(define (quotation-text expr) (cadr expr)) + +;;; assignment +(define (assignment? expr) (tagged? expr 'set!)) + +(define (eval-expr expr env) + (cond + [(self-evaluating? expr) expr] + [(if-else? expr) (eval-if expr env)] + [(quote-form? expr) (quotation-text expr)] + [(function-application? expr) + (apply-expr (operator expr) + (list-of-values (operands expr) env))])) + +(define (eval-if expr env) + (if (true? (eval-expr (if-predicate expr) env)) + (eval-expr (if-consequent expr) env) + (eval-expr (if-alternative expr) env))) + +(define (primitive? proc) + (is-elem-assoc-list proc primitives)) + +(define (apply-primitive-proc proc args) + (let ([p (lookup-assoc-list proc primitives)]) + (apply p args))) + +(define (apply-expr proc args) + (cond + [(primitive? proc) (apply-primitive-proc proc args)] + [else 'false])) diff --git a/prelude/primitives.scm b/prelude/primitives.scm new file mode 100644 index 0000000..96dd1dd --- /dev/null +++ b/prelude/primitives.scm @@ -0,0 +1,36 @@ +(define (true? expr) (eq? expr 'true)) +(define (false? expr) (eq? expr 'false)) +(define (bool? expr) + (or (true? expr) + (false? expr))) + +(define (and-special . items) + (if (null? items) + 'false + (let ([first (car items)]) + (cond + [(true? first) (apply and-special (cdr items))] + [(false? first) 'false] + [else (error "AND: unable to evaluate non-boolean form" first)])))) + +(define (or-special . items) + (if (null? items) + 'false + (let ([first (car items)]) + (cond + [(true? first) 'true] + [(false? first) (apply or-special (cdr items))] + [else (error "OR: unable to evaluate non-boolean form" first)])))) + +(define (not-fn x) (not (true? x))) + +(define primitives + `((+ . ,+) + (- . ,-) + (* . ,*) + (&& . ,and-special) + (|| . ,or-special) + (/= . ,not-fn))) + +(define (primitive-names) (map car primitives)) +(define (primitive-objs) (map cdr primitives)) diff --git a/util/alist.scm b/util/alist.scm new file mode 100644 index 0000000..4e19440 --- /dev/null +++ b/util/alist.scm @@ -0,0 +1,12 @@ +(define (is-elem-assoc-list key assoc-list) + (cond + [(null? assoc-list) #f] + [(eq? key (caar assoc-list)) #t] + [else (lookup-assoc-list key (cdr assoc-list))])) + +(define (lookup-assoc-list key assoc-list) + (cond + [(null? assoc-list) #f] + [(eq? key (caar assoc-list)) (cdar assoc-list)] + [else (lookup-assoc-list key (cdr assoc-list))])) + diff --git a/util/table.scm b/util/table.scm new file mode 100644 index 0000000..7cc68e8 --- /dev/null +++ b/util/table.scm @@ -0,0 +1,21 @@ +(define (make-table) + (list '*table*)) + +(define (key-assoc key records) + (cond + [(null? records) #f] + [(equal? key (caar records)) (car records)] + [else (key-assoc key (cdr records))])) + +(define (lookup key table) + (let ([r (key-assoc key (cdr table))]) + (if r + (cdr r) + #f))) + +(define (table-insert! key value table) + (let ([r (key-assoc key (cdr table))]) + (if r + (set-cdr! r value) + (set-cdr! table (cons (cons key value) + (cdr table)))))) -- cgit v1.2.3