diff --git a/repl/repl.scm b/repl/repl.scm new file mode 100644 index 0000000..ce79a52 --- /dev/null +++ b/repl/repl.scm @@ -0,0 +1,214 @@ +;; -*- Mode: Irken -*- + +(include "self/lisp_reader.scm") + +;; --- s-expression input --- + +(define (find-and-read-file path) + (raise (:NoIncludeFiles)) + ) + +(define (file/read-line file) + (let loop ((ch (file/read-char file)) + (r '())) + (if (eq? ch #\newline) + (list->string (reverse r)) + (loop (file/read-char file) (list:cons ch r))))) + +(define (ask prompt file) + (printf prompt) (flush) + (file/read-line file)) + +;; --- universal datatype --- +;; +;; this datatype covers all the types known by the interpreter. +;; + +(datatype univ + (:int int) + (:char char) + (:string string) + (:bool bool) + (:symbol symbol) + (:undef) + (:list (list univ)) + (:function (list symbol) sexp) + ) + +;; how to print out a universal value + +(define univ-repr + (univ:int n) -> (format (int n)) + (univ:char n) -> (format (char n)) + (univ:string s) -> (format (string s)) + (univ:bool b) -> (format (bool b)) + (univ:symbol s) -> (format (sym s)) + (univ:undef) -> "#u" + (univ:list subs) + -> (format "(" (join univ-repr " " subs) ")") + (univ:function rands body) + -> (format "string " " rands) ") " (repr body) ">") + ) + +;; lexical environment. +;; +;; a 'rib' consists of a set of variable bindings. +;; when a function is called, the arguments are evaluated +;; and bound to their formal variable names in a new rib, +;; which is pushed onto the environment for that call. + +;; the keys are symbols, the values are a record type containing a single +;; field named 'val', of type 'univ'. +;; the values must be placed in some kind of mutable storage, for set! to work. + +(datatype env + (:empty) + (:rib (alist symbol {val=univ}) env) + ) + +(define (repl-error what) + (printf "error: " what "\n") + (univ:undef) + ) + +(define namespace (env:empty)) + +(define (get-cell name env) + (match env with + (env:empty) + -> (maybe:no) + (env:rib rib next) + -> (match (alist/lookup rib name) with + (maybe:no) -> (get-cell name next) + (maybe:yes cell) -> (maybe:yes cell) + ) + )) + +(define (varref name env) + (match (get-cell name env) with + (maybe:no) -> (repl-error (format "undefined variable: " (sym name))) + (maybe:yes {val=val}) -> val + )) + +(define (varset name val env) + (match (get-cell name env) with + (maybe:no) ;; not defined, create a top-level entry + -> (let ((cell {val=val})) + (match namespace with + (env:empty) + -> (set! namespace (env:rib (alist:entry name cell (alist:nil)) (env:empty))) + (env:rib rib next) + -> (set! namespace (env:rib (alist:entry name cell rib) next)) + )) + (maybe:yes cell) + -> (set! cell.val val) + ) + (univ:undef) + ) + +;; evaluate a primitive operator (one starting with '%') + +(define eval-prim + '%+ (arg0 arg1) env + -> (let ((a (eval arg0 env)) + (b (eval arg1 env))) + (match a b with + (univ:int a) (univ:int b) -> (univ:int (+ a b)) + _ _ -> (repl-error (format "bad args: " (univ-repr a) " " (univ-repr b))) + )) + '%- (arg0 arg1) env + -> (let ((a (eval arg0 env)) + (b (eval arg1 env))) + (match a b with + (univ:int a) (univ:int b) -> (univ:int (- a b)) + _ _ -> (repl-error (format "bad args: " (univ-repr a) " " (univ-repr b))) + )) + prim _ _ + -> (repl-error (format "unknown prim: " (sym prim))) + ) + +(define (make-function rands body) + (let ((formals '())) + (for-list rand rands + (match rand with + (sexp:symbol name) + -> (begin (PUSH formals name) (univ:undef)) + _ -> (repl-error (format "bad formals: " (repr (sexp:list rands)))) + )) + (univ:function (reverse formals) body) + )) + +;; build an environment rib for these formals +;; and operands, ready to be pushed onto the lexical +;; environment. +(define (eval-args fun formals rands env) + (let loop ((formals formals) + (rands rands) + (rib (alist:nil))) + (match formals rands with + (name . formals) (arg . rands) + -> (loop formals rands (alist:entry name {val=(eval arg env)} rib)) + () () + -> (maybe:yes rib) + _ _ + -> (maybe:no) + ))) + +(define (eval-apply rator rands env) + (match (eval rator env) with + (univ:function formals body) + -> (match (eval-args rator formals rands env) with + (maybe:no) -> (repl-error (format "wrong number of arguments to function " (repr rator))) + (maybe:yes new-rib) + -> (eval body (env:rib new-rib env)) + ) + op -> (repl-error (format "operator is not a function: " (univ-repr op))) + )) + +;; top-level eval function + +(define (eval exp env) + (match exp with + ;; self-evaluating expressions + (sexp:int n) -> (univ:int n) + (sexp:char ch) -> (univ:char ch) + (sexp:string s) -> (univ:string s) + (sexp:bool b) -> (univ:bool b) + (sexp:undef) -> (univ:undef) + ;; variable lookup + (sexp:symbol s) -> (varref s env) + ;; variable assignment + (sexp:list ((sexp:symbol 'set!) (sexp:symbol name) val)) + -> (varset name (eval val env) env) + ;; lambda + (sexp:list ((sexp:symbol 'lambda) (sexp:list formals) body)) + -> (make-function formals body) + ;; application + (sexp:list (rator . rands)) + -> (match rator with + (sexp:symbol name) + -> (if (starts-with (symbol->string name) "%") + (eval-prim name rands env) + (eval-apply rator rands env)) + _ -> (eval-apply rator rands env)) + ;; anything else... + exp -> (repl-error (format "bad/unknown expression: " (repr exp))) + )) + +(define (setup-initial-environment) + (varset 'x (univ:int 34) namespace) + ) + +(define (read-eval-print-loop stdin) + (setup-initial-environment) + (let loop ((line (ask "> " stdin))) + (match (string-length line) with + 0 -> #u + _ -> (begin + ;;(printf "line = '" line "'\n") + (for-list exp (read-string line) + (printf (univ-repr (eval exp namespace)) "\n")) + (loop (ask "> " stdin))) + ))) + +(read-eval-print-loop (file/open-stdin))