diff options
Diffstat (limited to 'simple.scm')
| -rw-r--r-- | simple.scm | 250 |
1 files changed, 250 insertions, 0 deletions
diff --git a/simple.scm b/simple.scm new file mode 100644 index 0000000..6e4c3c4 --- /dev/null +++ b/simple.scm @@ -0,0 +1,250 @@ + +; cyclic dependency graph (sigh) +; +; meaning +; expression-to-action +; list-to-action +; *application +; meaning +; +; actions + +; ### preliminaries, utilities, shorthand + +; check if something is an atom vs {null, collection} +(define atom? + (lambda (x) + (and (not (pair? x)) (not (null? x))))) + +; need a list or tuple type; tuples prefered +(define first + (lambda (p) (car p))) + +(define second + (lambda (p) (car (cdr p)))) + +(define third + (lambda (p) (car (cdr (cdr p))))) + +(define build + (lambda (a b) (cons a (cons b (quote ()))))) + +(define text-of second) + +; test functions +(define add1 (lambda (x) (+ x 1))) +(define sub1 (lambda (x) (- x 1))) + +; table operations +(define new-entry build) + +(define lookup-in-entry + (lambda (name entry entry-f) + (lookup-in-entry-help name + (first entry) + (second entry) + entry-f))) + +(define lookup-in-entry-help + (lambda (name names values entry-f) + (cond + ((null? names) (entry-f name)) + ((eq? (car names) name) (car values)) + (else (lookup-in-entry-help name (cdr names) (cdr values) entry-f))))) + +(define extend-table cons) + +(define lookup-in-table + (lambda (name table table-f) + (cond + ((null? table) (table-f name)) + (else (lookup-in-entry name + (car table) + (lambda (n) + (lookup-in-table n (cdr table) table-f))))))) + +(define initial-table + (lambda (name) + (car (quote ())))) + +;(lookup-in-entry 'fish +; '((teach a man to fish) +; (1 2 3 4 5)) +; (lambda (x) x)) + +;(lookup-in-table 'fish +; (extend-table '((teach a man to fish) +; (1 2 3 4 5)) +; (quote ())) +; (lambda (x) x)) + +; ### specific types/helpers +(define builtin? + (lambda (l) + (eq? (first l) (quote builtin)))) + +(define non-builtin? + (lambda (l) + (eq? (first l) (quote non-builtin)))) + +(define else? + (lambda (x) + (cond + ((atom? x) (eq? x (quote else))) + (else #f)))) + +(define table-of first) +(define formals-of second) +(define body-of third) +(define question-of first) +(define answer-of second) +(define cond-lines-of cdr) +(define function-of car) +(define arguments-of cdr) + +; need generic true/false booleans, a number type, and a symbol type +; also need a mutable "table" collection +(define *const + (lambda (e table) + (cond + ((number? e) e) + ((eq? e #t) #t) + ((eq? e #f) #f) + (else (build (quote builtin) e))))) +;(*const 'asdf '()) ; (builtin asdf) + +(define *lambda + (lambda (e table) + (build (quote non-builtin) (cons table (cdr e))))) +;(*lambda '(lambda (a b) (cond ((eq? a b) b) (else a))) '( ((1 2 3) (a b c)))) +; (non-builtin ((((1 2 3) (a b c))) (a b) (cond ((eq? a b) b) (else a)))) + +(define *quote + (lambda (e table) + (text-of e))) +;(*quote '(quote stuff) '()) ; stuff + +(define *identifier + (lambda (e table) + (lookup-in-table e table initial-table))) +;(*identifier 'asdf '()) ; error +;(*identifier 'a '( ((1 2 3 a b c) (first second third 1 2 3)))) ; 1 + +(define *cond + (lambda (e table) + (evcon (cond-lines-of e) table))) + +(define :atom? + (lambda (x) + (cond + ((atom? x) #t) + ((null? x) #f) + ((eq? (car x) (quote builtin)) #t) + ((eq? (car x) (quote non-builtin)) #t) + (else #f)))) + +; ### now we start the meat! + +(define atom-to-action + (lambda (e) + (cond + ((number? e) *const) + ((eq? e #t) *const) + ((eq? e #f) *const) + ((eq? e (quote cons)) *const) + ((eq? e (quote car)) *const) + ((eq? e (quote cdr)) *const) + ((eq? e (quote null?)) *const) + ((eq? e (quote eq?)) *const) + ((eq? e (quote atom?)) *const) + ((eq? e (quote zero?)) *const) + ((eq? e (quote add1)) *const) + ((eq? e (quote sub1)) *const) + ((eq? e (quote number?)) *const) + (else *identifier)))) +;(atom-to-action 'number?); *const + +(define list-to-action + (lambda (e) + (cond + ((atom? (car e)) (cond + ((eq? (car e) (quote quote)) *quote) + ((eq? (car e) (quote lambda)) *lambda) + ((eq? (car e) (quote cond)) *cond) + (else *application))) + (else *application)))) +;(list-to-action '(lambda (x) x)) ; *lambda +;(list-to-action '(cond ((eq? 1 2) #f) (else #t))) ; *cond + +(define expression-to-action + (lambda (e) + (cond + ((atom? e) (atom-to-action e)) + (else (list-to-action e))))) +;(expression-to-action '#f) ; *const +;(expression-to-action '(lambda (x) x)) ; *lambda + +(define evcon + (lambda (lines table) + (cond + ((else? (question-of (car lines))) + (meaning (answer-of (car lines)) table)) + ((meaning (question-of (car lines)) table) + (meaning (answer-of (car lines)) table)) + (else (evcon (cdr lines) table))))) + +(define evlis + (lambda (args table) + (cond + ((null? args) (quote ())) + (else (cons (meaning (car args) table) + (evlis (cdr args) table)))))) +;(evlis '(cons #f 4) '()) ; ((builtin cons) #f 4) + +(define *application + (lambda (e table) + (apply2 + (meaning (function-of e) table) + (evlis (arguments-of e) table)))) + +; basic, low-level, non-compound functions +(define apply-builtin + (lambda (name vals) + (cond + ((eq? name (quote cons)) (cons (first vals) (second vals))) + ((eq? name (quote car)) (car (first vals))) + ((eq? name (quote cdr)) (cdr (first vals))) + ((eq? name (quote null?)) (null? (first vals))) + ((eq? name (quote eq?)) (eq? (first vals) (second vals))) + ((eq? name (quote atom?)) (:atom? (first vals))) + ((eq? name (quote zero?)) (zero? (first vals))) + ((eq? name (quote add1)) (add1 (first vals))) + ((eq? name (quote sub1)) (sub1 (first vals))) + ((eq? name (quote number?)) (number? (first vals)))))) + +; for compound functions +(define apply-closure + (lambda (closure vals) + (meaning (body-of closure) + (extend-table (new-entry (formals-of closure) vals) + (table-of closure))))) + +; this is "how apply would be implemented"; it isn't used in this file +(define apply2 + (lambda (fun vals) + (cond + ((builtin? fun) (apply-builtin (second fun) vals)) + ((non-builtin? fun) (apply-closure (second fun) vals))))) + +; find the value of an s-expression in the context of an environment +(define meaning + (lambda (e table) + ((expression-to-action e) e table))) +;(meaning '(lambda (x) (cons x y)) '(((y z) ((8) 9)))) +; (non-primative ((((y z) ((8) 9)))) (x) (cons x y)) + +; and finally, helper to find values in a starting environment +(define value + (lambda (e) + (meaning e (quote ())))) +;(value '((lambda (a b) (a (add1 b))) (lambda (c) (add1 c)) 4)) ; 6 |