rscheme.clj
;; Copyright (c) Andrzej Radecki. All rights reserved.
;; The use and distribution terms for this software are covered by the
;; Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
;; which can be found in the file CPL.txt at the root of this distribution.
;; By using this software in any fashion, you are agreeing to be bound by
;; the terms of this license.
;; You must not remove this notice, or any other, from this software.
;;
;; File: rscheme.clj
;;
;; rscheme.clj contains an implementation of a reader and an evaluator
;; of a simple, scheme-like language. It can be used as a sand-box
;; (an isolated and restricted execution environment) for interpreting
;; scripts that if executed directly by clojure could pose a security
;; risk to the system.
;;
;; Note that this software was neither developed for conformance with the R5RS
;; standard nor for the execution efficiency.
;;
;; Functions:
;; 'eval' - scheme evaluator (stub)
;; 'read' - scheme reader
;; 'repl' - Read-Eval-Print-Loop function of the scheme interpreter
;;
;; (gmail) nrdwrdck
;; 09 May 2008
;;
(in-ns 'rscheme)
(clojure/refer 'clojure :exclude '(eval read))
(def #^{:private true} stack-depth 100)
(def #^{:private true} trace 0)
(def #^{:private true} eval)
(def #^{:private true} print-exp)
(defn- make-number [n]
{:type :number :val n})
(defn- make-bool [n]
{:type :bool :val n})
(defn- make-true
{:type :bool :val true})
(defn- make-false
{:type :bool :val false})
(defn- make-list [l]
{:type :list :val l})
(defn- make-nil []
(make-list nil))
(defn- is-symbol? [t]
(= (:type t) :symbol))
(defn- is-list? [t]
(= (:type t) :list))
(defn- is-nil? [l]
(and (= (:type l) :list) (nil? (:val l))))
(defn- with-env [val env]
(assoc val :env env))
(defn- val-op
"Performs an operation op on field :val of a map mp
and return the modified map"
[mp op]
(let [inner (:val mp)]
(assoc mp :val (op inner))))
(defn- val-conj
[mp val]
(val-op mp (fn [inner] (conj inner val))))
(defn- val-first [mp]
(val-op mp first))
(defn- val-rest [mp]
(val-op mp rest))
(defn- val-frest [mp]
(val-op mp frest))
(defn- val-rrest [mp]
(val-op mp rrest))
(defn- prim_add
[& xs]
(make-number (apply + (map :val xs))))
(defn- prim_sub
[& xs]
(make-number (apply - (map :val xs))))
(defn- prim_mul
[& xs]
(make-number (apply * (map :val xs))))
(defn- prim_div
[& xs]
(make-number (apply / (map :val xs))))
(defn- prim_gt
[& xs]
(make-bool (apply > (map :val xs))))
(defn- prim_lt
[& xs]
(make-bool (apply < (map :val xs))))
(defn- prim_eq
[& xs]
(make-bool (apply = (map :val xs))))
(defn- prim_display-helper
[int? first? & xs]
;;(println first? xs)
(if (nil? xs)
(make-nil)
(do (if (not first?)
(print " "))
(print-exp int? (first xs))
(recur int? false (rest xs)))))
(defn- prim_display
[& xs]
(apply prim_display-helper false true xs))
(defn- prim_write
[& xs]
(apply prim_display-helper true true xs))
(defn- frrest [l] (-> l rrest first))
(defn- frrrest [l] (-> l rrest rest first))
(defn- pos-string [ann]
(str (:fname ann) ":" (:line ann) ":" (:col ann)))
(defn- indent
"Displays lvl consequtive [char] characters"
[char lvl]
(when (pos? lvl)
(do (print char) (recur char (dec lvl)))))
(defn- print-bool
[val]
(if val
(print "#t")
(print "#f")))
(defn- print-number
[val]
(print val))
(defn- print-char
[int? val]
(if int?
(pr val)
(print val)))
(defn- print-string
[int? val]
(if int?
(pr val)
(print val)))
(defn- print-symbol
[val]
(print (name val)))
(defn- print-list
([val]
(print-list val true))
([val first?]
(if first? (print "("))
(if (nil? val)
(print ")")
(do (if (not first?)
(print " "))
(print-exp true (first val))
(recur (rest val) false)))))
(defn- print-exp
[int? exp]
(when (map? exp)
(let [type (:type exp) val (:val exp)]
;;(println type val)
(cond
(= type :bool) (print-bool (:val exp))
(= type :number) (print-number (:val exp))
(= type :char) (print-char int? (:val exp))
(= type :string) (print-string int? (:val exp))
(= type :symbol) (print-symbol (:val exp))
(= type :list) (print-list (:val exp))))))
(defn- extend-environment
[env arg-list param-list]
(cond (and (nil? arg-list) (nil? param-list))
env
(or (= (count arg-list) 0) (= (count param-list) 0))
nil
:else
(recur (assoc env (:val (first arg-list)) (first param-list))
(rest arg-list) (rest param-list))))
(defn- extend-env
[env arg-list param-list def-ok? tail?]
(extend-environment
{:parent env :level (+ 1 (:level env)) :tail? tail? :def-ok? def-ok?}
arg-list param-list))
(defn- make-env [env def-ok? tail?]
(extend-env env nil nil def-ok? tail?))
(defn- eval-sequence
"Eval a list of forms. Tail recursive.
\"define's\" are only allowed at the beginning of the list."
([exps env]
(eval-sequence exps env (with-env (make-nil) env) true))
([exps env res def-ok]
(if (nil? exps)
res
(let [res (eval (first exps)
(assoc env
:def-ok? def-ok
:tail? (nil? (rest exps))))
env (:env res)
def-ok (:definition res)]
(recur (rest exps) env res def-ok)))))
(defn- eval-sequence-top
"Eval a top-level list of forms.
\"define's\" are always allowed.
Not tail recursive (is it necessary(?))"
([exps env]
(eval-sequence-top exps env (with-env (make-nil) env)))
([exps env res]
(if (nil? exps)
res
(let [res (eval (first exps) env)
env (:env res)]
(recur (rest exps) env res)))))
(defn- eval-symbol
([exp env]
(let [name (:val exp)]
(eval-symbol exp env env name)))
([exp env-orig env var]
(if (contains? env var)
(with-env (get env var) env-orig)
(if (nil? (:parent env))
(do (println
(str "Unbound variable " (:val exp) ", "
(pos-string (:start exp))))
(with-env (make-nil) env-orig))
(recur exp env-orig (:parent env) var)))))
(defn- eval-quote
[exp env]
(when (> (count (:val exp)) 2)
(let [ann (:start exp)]
(println
(str "Unused arguments to \"quote\", "
(pos-string ann)))))
(with-env (frest (:val exp)) env))
(defn- eval-assign
[exp env]
)
(defn- eval-if
"add error checking"
[exp env]
(let [vec (:val exp) cond (frest vec) pred (frrest vec) alt (frrrest vec)]
;;(let [c (eval cond (make-env env false true))]
(let [c (eval cond (assoc env :def-ok? false :tail? true))]
(if (:val c)
;;(eval pred (make-env env false true))
(eval pred (assoc env :def-ok? false :tail? true))
(if (nil? alt)
(with-env (make-nil) env)
;;(eval alt (make-env env false true)))))))
(eval alt (assoc env :def-ok false :tail? true)))))))
(defn- eval-cond
[exp env]
)
(defn- parse-formals-list
([lst exp]
(parse-formals-list lst exp (list) nil))
([lst exp res res2]
(if (nil? lst)
{:arg-list (reverse res) :arg-rest (reverse res2)}
(if (is-symbol? (first lst))
(recur (rest lst) exp (cons (first lst) res) res2)
(println
(str "Invalid symbol in the argument list "
(pos-string (:start exp))))))))
(defn- parse-formals
([var exp env]
(cond (= (:type var) :symbol)
{:arg-rest var :arg-list nil}
(= (:type var) :list)
(parse-formals-list (:val var) exp)
:else
(println
(str "Invalid argument list "
(pos-string (:start exp)))))))
(defn- eval-lambda
[exp env]
(let [vec (:val exp) var (frest vec)
body (rrest vec)]
;;body (subvec vec 2)]
(if (or (nil? var) (nil? body))
(do (println
(str
"Not enough arguments to \"lambda\" "
(pos-string (:start exp))))
(with-env (make-nil) env))
(let [formals (parse-formals var exp env)
arg-list (:arg-list formals)
arg-rest (:arg-rest formals)]
(if (nil? formals)
(with-env (make-nil) env)
(with-env {:body body :arg-list arg-list
:arg-rest arg-rest :type :fun
:start (:start exp) :end (:end exp)}
env))))))
(defn- eval-define
[exp env]
(let [vec (:val exp) var (frest vec) val-exp (frrest vec)]
(cond
;;value
(and (= (:type var) :symbol)
(not (nil? val-exp)))
(let [res (eval val-exp (make-env env false true))
val (dissoc res :env)
env (:parent (:env res))]
(with-env res (assoc env (:val var) val)))
;;procedure
(and (= (:type var) :list)
(= (:type (first (:val var))) :symbol)
(not (nil? val-exp)))
(let [sym (first (:val var))
;;args (subvec (:val var) 1)
;;body (subvec vec 2)
args (rest (:val var))
body (rrest vec)
formals (parse-formals-list args var)
arg-list (:arg-list formals)
arg-rest (:arg-rest formals)
res {:body body :arg-list arg-list
:arg-rest arg-rest :type :fun
:start (:start exp) :end (:end exp)}]
(if (nil? formals)
(with-env (make-nil) env)
(with-env res (assoc env (:symbol sym) res))))
;;unknown
:else
(let [ann (:start var)]
(println
(str "Invalid format of \"define\" form "
(pos-string ann)))
(with-env (make-nil) env)))))
(defn- eval-begin
[exp env]
)
(defn- eval-and
[exp env]
)
(defn- eval-or
[exp env]
)
(defn- eval-arguments
([exps env]
(eval-arguments exps env (list)))
([exps env lst]
(if (nil? exps)
(reverse lst)
;;(let [res (eval (first exps) (make-env env false false))
(let [res (eval (first exps) (assoc env :def-ok? false :tail? false))
val (dissoc res :env)]
(recur (rest exps) env (cons val lst))))))
(defn- eval-primitive
[op exp env]
;;{:val (apply (get primitives (:val (first exp))) '(5 6))
(let [res (apply (:val op)
(eval-arguments
(rest (:val exp))
env))]
(when (> trace 1)
(indent "+" (:level env))
(print " ")
(print-exp true res)
(print "\t")
(print-exp true exp)(newline))
(with-env res env)))
(defn- eval-procedure
[op exp env]
(let [params (eval-arguments (rest (:val exp)) env)
nenv
(if (:tail? env)
(extend-environment env (:arg-list op) params)
(extend-environment
{:parent env :level (+ 1 (:level env)) :tail? false}
(:arg-list op) params))]
(cond (nil? nenv)
(do (println
(str
"Procedure applied to wrong number of arguments. "
"Expected " (count (:arg-list op))
", given " (count params) ". " (pos-string (:start exp))))
(with-env (make-nil) env))
(> (:level env) stack-depth)
(do (println
(str
"Stack overflow, " (pos-string (:start exp))))
(with-env (make-nil) env))
:else
(let [res (eval-sequence (:body op) nenv)]
(if (:tail? env)
res
(do (with-env (dissoc res :env) (:parent (:env res)))))))))
(defn- eval-application
[exp env]
;;(let [op (eval (first (:val exp)) (make-env env false false))]
(let [op (eval (first (:val exp))
(assoc env :def-ok? false :tail? false))]
(cond (= (:type op) :primitive-fun)
(eval-primitive op exp env)
(= (:type op) :fun)
(eval-procedure op exp env)
;;(is-nil? op)
;;(with-env (make-nil) env)
:else
(do (println
(str "First element of the form is not a procedure, "
(pos-string (:start exp))))
(with-env (make-nil) env)))))
;;----
(defmulti eval-form
(fn [exp env]
(when (> trace 0)
(indent "-" (:level env))
(print " ")
(print-exp true exp)(newline))
(:val (first (:val exp)))))
(defmethod eval-form 'quote
[exp env]
(eval-quote exp env))
(defmethod eval-form 'set!
[exp env]
(eval-assign exp env))
(defmethod eval-form 'define
[exp env]
(if (:def-ok? env)
(eval-define exp env)
(do (println
(println
(str "Definition is not allowed in this context, "
(pos-string (:start exp)))))
(with-env (make-nil) env))))
(defmethod eval-form 'if
[exp env]
(eval-if exp env))
(defmethod eval-form 'cond
[exp env]
(eval-cond exp env))
(defmethod eval-form 'lambda
[exp env]
(eval-lambda exp env))
(defmethod eval-form 'begin
[exp env]
(eval-begin exp env))
(defmethod eval-form 'and
[exp env]
(eval-and exp env))
(defmethod eval-form 'or
[exp env]
(eval-or exp env))
(defmethod eval-form :default
[exp env]
(eval-application exp env))
;;-----
(defmulti eval (fn [exp env] (:type exp)))
(defmethod eval :bool
[exp env]
(with-env exp env))
(defmethod eval :number
[exp env]
(with-env exp env))
(defmethod eval :char
[exp env]
(with-env exp env))
(defmethod eval :string
[exp env]
(with-env exp env))
(defmethod eval :symbol
[exp env]
(when (> trace 2)
(indent "-" (:level env))
(print " ")
(print-exp true exp)(newline))
(let [res (eval-symbol exp env)]
(when (> trace 2)
(indent "+" (:level env))
(print " ")
(print-exp true res)
(print "\t")
(print-exp true exp)(newline))
res))
(defmethod eval :list
[exp env]
(eval-form exp env))
(defmethod eval :default
[exp env]
(println
(str "Unrecognised expression "
(pos-string (:start exp))))
(with-env (make-nil) env))
(defn- prompt-for-input
"Displays an input prompt"
[]
(println)
(println "Scheme: ")
(flush))
(defn- output-prompt
"Displays a result prompt"
[]
(newline)
(println "Result:"))
(defn- pprint
"A simple \"pretty print\" function suitable for debugging syntax trees
(as returned by read function)"
([val]
(pprint val 0))
([val lvl]
(indent " " lvl)
(if (and (= (:type val) :list) (not (nil? (:val val))))
(do
(println "(")
(doseq elem (:val val) (pprint elem (+ lvl 2)))
(indent " " lvl)
(println ")"))
(prn val))))
(defn- next-pos
"Returns a structure containing line, column and character number of the
character to be read.
pos - line, column and character number of the current character
ch - current character"
[pos ch]
(let [ch (char ch) line (:line pos) col (:col pos) cnt (+ (:cnt pos) 1)]
(if (= ch \newline)
(assoc pos :line (+ line 1) :col 1 :cnt cnt)
(assoc pos :line line :col (+ col 1) :cnt cnt))))
(defn- char-seq-helper
[stream close? pos]
(let [ch (. stream (read))]
(if (== ch -1)
(when close?
(. stream (close)))
;; (lazy-cons (. Character (toString (char ch)))
;; (char-seq stream close?))))))
(lazy-cons (assoc pos :ch (char ch))
(char-seq-helper stream close? (next-pos pos ch))))))
(defn char-seq
"Reads an input stream (*in* if called without arguments) and returns
a lazy sequence of characters in this stream"
([]
(char-seq *in*))
([stream]
(char-seq stream "STDIN" false))
([stream fname close?]
(char-seq-helper stream close? {:line 1, :col 1, :cnt 1, :fname fname})))
(defn char-seq-from-file
"Reads an input file f and returns a lazy sequence of characters
included this file"
[#^String f]
;; (with-open r (new java.io.FileReader f)
(let [r (new java.io.FileReader f)]
(char-seq r f true)))
(defn- whitespace?
[ch]
(. Character (isWhitespace ch)))
(defn- digit?
[ch]
(. Character (isDigit ch )))
(defn- tappend
"Appends characters (chars) to the :txt field of the token structure"
[token & chars]
(assoc token :txt (reduce str (:txt token) chars)))
(defn- delimiter?
"Is character (ch) a delimiter?"
[ch]
(or (whitespace? ch) (= ch \() (= ch \)) (= ch \;)
(= ch \") (= ch \') (= ch \`) (= ch \,)))
(defn- parse-unicode
([cseq]
(parse-unicode cseq 4 0))
([cseq cnt val]
(if (= cnt 0)
val
(let [ch (:ch (first cseq))
digit (. Character (digit ch 16))]
(if (= digit -1)
nil
(recur (rest cseq) (- cnt 1) (+ (* val 16) digit)))))))
(defn- escape-char
[cseq]
(let [ch (:ch (frest cseq))]
(cond (= ch \n) [\newline (rrest cseq)]
(= ch \t) [\tab (rrest cseq)]
(= ch \r) [(char 13) (rrest cseq)]
(= ch \b) [\backspace (rrest cseq)]
(= ch \f) [\formfeed (rrest cseq)]
(= ch \\) [\\ (rrest cseq)]
(= ch \') [\' (rrest cseq)]
(= ch \") [\" (rrest cseq)]
(= ch \u) (let [val (parse-unicode (rrest cseq))]
(if (not (nil? val))
[(char val) (rrest (rrest (rrest cseq)))]
[nil (rrest cseq)]))
:else [nil (rrest cseq)])))
(defn token-seq
"Consumes a lazy sequence of characters (as returned by char-seq)
and produces a lazy sequence of tokens.
If called without arguments it attempts to read characters from
the *in* stream"
([]
(token-seq (char-seq *in*)))
([cseq]
(token-seq cseq {:type :whitespace}))
([cseq token]
(let [ch (:ch (first cseq)) ann (dissoc (first cseq) :ch)
type (:type token) text (:txt token)]
;; (println ch)
(cond
;; end of stream
(nil? ch) nil
;; comments
(= type :comment)
(if (= ch \newline)
(recur (rest cseq) (assoc token :type :whitespace))
(recur (rest cseq) token))
;; whitespaces (or borders of tokens)
(= type :whitespace)
(cond (whitespace? ch) (recur (rest cseq) token)
(= ch \;) (recur (rest cseq) (assoc token :type :comment))
(= ch \") (recur (rest cseq)
(assoc token :type :string :start ann))
(or (= ch \-) (= ch \+))
(recur (rest cseq)
(assoc (tappend token ch) :type :sign :start ann))
(digit? ch) (recur (rest cseq)
(assoc (tappend token ch)
:type :begin-number :start ann))
(= ch \#) (recur (rest cseq)
(assoc (tappend token ch)
:type :hash :start ann))
(= ch \\) (recur cseq
(assoc (tappend token ch)
:type :char :start ann))
(= ch \') (lazy-cons
{:type :symbol :txt (str ch)
:val (symbol "quote") :expand true
:start ann :end ann}
(token-seq (rest cseq)))
(= ch \`) (lazy-cons
{:type :symbol :txt (str ch)
:val (symbol "quasiquote") :expand true
:start ann :end ann}
(token-seq (rest cseq)))
(= ch \,) (lazy-cons
{:type :symbol :txt (str ch)
:val (symbol "unquote") :expand true
:start ann :end ann}
(token-seq (rest cseq)))
(= ch \() (lazy-cons
{:type :lparen :txt (str ch)
:start ann :end ann}
(token-seq (rest cseq)))
(= ch \)) (lazy-cons
{:type :rparen :txt (str ch)
:start ann :end ann}
(token-seq (rest cseq)))
:else (recur (rest cseq)
(assoc (tappend token ch) :type :symbol
:start ann)))
;; strings
(= type :string)
(cond (= ch \\) (let [res (escape-char cseq)
ch (first res)
ncseq (second res)]
(recur ncseq (tappend token ch)))
(= ch \") (lazy-cons
(assoc token :val (:txt token) :end ann)
(token-seq (rest cseq)))
:else (recur (rest cseq) (tappend token ch)))
;; characters
(= type :char)
(let [res (escape-char cseq)
ch2 (first res)
ncseq (second res)]
(if (nil? ch2)
;;(recur cseq (assoc token :type :unknown))
(let [ch (:ch (frest cseq))
ann (dissoc (frest cseq) :ch)]
(lazy-cons (assoc (tappend token ch)
:val ch :end ann)
(token-seq (rrest cseq))))
(let [ann (dissoc (first ncseq) :ch)]
(lazy-cons (assoc (tappend token ch2)
:val ch2 :end ann :ch)
(token-seq ncseq)))))
;; boolean literals
(= type :hash)
(cond (or (= ch \t) (= ch \T))
(lazy-cons
(assoc (tappend token ch)
:type :bool :val true :end ann)
(token-seq (rest cseq)))
(or (= ch \f) (= ch \F))
(lazy-cons
(assoc (tappend token ch)
:type :bool :val false :end ann)
(token-seq (rest cseq)))
:else (recur cseq (assoc token :type :symbol)))
;; numbers
;; take first digit after sign
(= type :sign)
(cond (digit? ch) (recur (rest cseq)
(assoc (tappend token ch)
:type :begin-number))
:else (recur cseq (assoc token :type :symbol)))
;; take remaining digits of the number and detect the format
(= type :begin-number)
(cond (digit? ch) (recur (rest cseq) (tappend token ch))
(= ch \.) (recur (rest cseq)
(assoc (tappend token ch)
:type :begin-decimal))
(= ch \/) (recur (rest cseq)
(assoc (tappend token ch)
:type :begin-quotient))
(or (= ch \e) (= ch \E)) (recur
(rest cseq)
(assoc (tappend token ch)
:type :begin-exponent))
(delimiter? ch)
(lazy-cons
(assoc token
:type :number :val (new BigInteger text) :end ann)
(token-seq cseq))
:else (recur (rest cseq)
(assoc (tappend token ch)
:type :unknown :error :numformat)))
;; take at least one digit of the decimal part
(= type :begin-decimal)
(cond (digit? ch) (recur (rest cseq)
(assoc (tappend token ch)
:type :decimal))
:else (recur cseq
(assoc token :type :unknown :error :numformat)))
;; collect remaining digits of the decimal part
(= type :decimal)
(cond (digit? ch) (recur (rest cseq) (tappend token ch))
(or (= ch \e) (= ch \E))
(recur (rest cseq)
(assoc (tappend token ch) :type :begin-exponent))
(or (= ch \m) (= ch \M))
(recur (rest cseq) (assoc token :type :big-decimal))
(delimiter? ch)
(lazy-cons
(assoc token
:type :number :val (new Double text) :end ann)
(token-seq cseq))
:else (recur (rest cseq)
(assoc (tappend token ch)
:type :unknown :error :numformat)))
;; make a "big decimal" value
(= type :big-decimal)
(cond
(delimiter? ch)
(lazy-cons
(assoc (tappend token \M) :type :number
:val (new BigDecimal text) :end ann)
(token-seq cseq))
:else (recur (rest cseq)
(assoc (tappend token ch)
:type :unknown :error :numformat)))
;; at least one digit in quotient
(= type :begin-quotient)
(cond (digit? ch) (recur (rest cseq)
(assoc (tappend token ch)
:type :quotient))
:else (recur cseq (assoc token
:type :unknown :error :numformat)))
;; rest of the quotient
(= type :quotient)
(cond (digit? ch) (recur (rest cseq) (tappend token ch))
(delimiter? ch)
(let [[n d] (split-with (fn [c] (not (= c \/))) text)]
(lazy-cons
(assoc token
:type :number
:val
(. clojure.lang.Numbers
(divide (new BigInteger (apply str n))
(new BigInteger (apply str (rest d)))))
:end ann)
(token-seq cseq)))
:else (recur
(rest cseq) (assoc (tappend token ch)
:type :unknown :error :numformat)))
;; take first exponent digit or exponent sign
(= type :begin-exponent)
(cond (digit? ch) (recur
(rest cseq)
(assoc (tappend token ch) :type :exponent))
(or (= ch \-) (= ch \+)) (recur
(rest cseq)
(assoc (tappend token ch)
:type :begin-exponent-digits))
:else (recur cseq (assoc token
:type :unknown :error :numformat)))
;; at least one digit in the exponent
(= type :begin-exponent-digits)
(cond (digit? ch) (recur (rest cseq) (assoc (tappend token ch)
:type :exponent))
:else (recur cseq (assoc token
:type :unknown :error :numformat)))
;; collect digits in the exponent
(= type :exponent)
(cond (digit? ch) (recur (rest cseq) (tappend token ch))
(delimiter? ch)
(lazy-cons (assoc token
:type :number :val (new Double text) :end ann)
(token-seq cseq))
:else (recur (rest cseq)
(assoc (tappend token ch)
:type :unknown :error :numformat)))
;; symbols
(= type :symbol)
(if
(delimiter? ch)
(lazy-cons (assoc token :val (symbol text) :end ann)
(token-seq cseq))
(recur (rest cseq) (tappend token ch)))
(= type :unknown)
(if
(delimiter? ch)
(lazy-cons (assoc token :end ann) (token-seq cseq))
(recur (rest cseq) (tappend token ch)))
))))
(defn token-seq-from-file
"Reads a file f and produces a lazy sequence of tokens"
[#^String f]
(token-seq (char-seq-from-file f)))
(defn- exit
"Exits from the clojure repl."
([]
(exit 0))
([exitcode]
(. System (exit exitcode))))
(defn- print-error
"Displays an error message selected by err keyword, requires a token
so that additional information can be provided to the user"
[err token]
(let [end (:end token) start (:start token)
fname (:fname start) line (:line start) col (:col start)]
;;(prn token)
(cond
(= err :eof)
(do
(println
(str "Unmatched left parenthesis, "
fname ":" line ":" col)))
(= err :rparen)
(println (str "Unmatched right parenthesis, "
fname ":" line ":" col))
(= err :numformat)
(println (str "Invalid number format: \"" (:txt token)
"\", " fname ":" line ":" col))
:else
(println (str "Unknown error, "
fname ":" line ":" col)))
;; (exit 1)
))
(defn- read-helper
[tseq vec root? single?]
(let [token (first tseq) type (:type token) ann (:end token)]
;;(prn token)
(if token
(cond
(= type :lparen)
(let [res (read-helper
(rest tseq)
{:type :list :val (list) :start (:start token)}
false false)
nvec (dissoc res :tseq :eof)
ntseq (:tseq res)]
(when (:eof res)
(print-error :eof token))
(let [val (if (= (count (:val nvec)) 0)
(assoc nvec :type :list :val nil)
nvec)]
(if single?
(assoc (val-conj vec val) :tseq ntseq)
(recur (rest ntseq) (val-conj vec val) root? false))))
(= type :rparen)
(if root?
(do (print-error :rparen token)
(assoc vec :tseq tseq :end ann :val (reverse (:val vec))))
(assoc vec :tseq tseq :end ann :val (reverse (:val vec))))
(:expand token)
(let [res (read-helper (rest tseq)
{:type :list :val (list token)}
false true)
nvec (dissoc res :tseq)
ntseq (:tseq res)]
(if single?
(assoc (val-conj vec nvec) :tseq ntseq)
(recur (rest ntseq) (val-conj vec nvec) root? false)))
(contains? token :error)
(do (print-error (:error token) token)
(if single?
(assoc (val-conj vec token) :tseq tseq)
(recur (rest tseq) (val-conj vec token) root? false)))
:else
(if single?
(assoc (val-conj vec token) :tseq tseq)
(recur (rest tseq) (val-conj vec token) root? false)))
(assoc vec :eof true :val (reverse (:val vec))))))
(defn read
"Consumes a sequence of tokens as returned by token-seq and produces
a syntax tree. Note that this function attempts to read the whole
token sequence"
([]
(read (token-seq (char-seq *in*))))
([tseq]
(dissoc
(read-helper tseq
{:type :list :val (list)}
true false)
:tseq)))
(defn read-form-seq
"Consumes a sequence of tokens as returned by token-seq and produces
a lazy sequence of syntax trees. Each syntax tree is single top-level
form. Note that this function attemtps to read the whole top-level form."
([]
(read-form-seq (token-seq (char-seq *in*)) true))
([tseq root?]
(when tseq
(let [form
(read-helper tseq {:type :list :val (list)} root? true)]
(lazy-cons
(first (:val form))
(read-form-seq (rest (:tseq form)) root?))))))
(defn read-file
"Reads a file fname and returns a syntax tree"
[#^String fname]
(read (token-seq-from-file fname)))
(def global-environment
#^{:private true}
{
;;(symbol "#f") false
;;(symbol "#t") true
;;'a {:val 1 :type :number}
;;'b {:body
;; [{:val [{:val 'display :type :symbol} {:val 'n :type :symbol}] :type :list}
;; {:val [{:val (symbol "+") :type :symbol} {:val 'n :type :symbol} {:val 'n :type :symbol}] :type :list}]
;; :arg-list
;; [{:val 'n :type symbol}]
;; :type :fun}
(symbol "+") {:val prim_add :type :primitive-fun}
(symbol "-") {:val prim_sub :type :primitive-fun}
(symbol "*") {:val prim_mul :type :primitive-fun}
(symbol "/") {:val prim_div :type :primitive-fun}
(symbol "=") {:val prim_eq :type :primitive-fun}
(symbol ">") {:val prim_gt :type :primitive-fun}
(symbol "<") {:val prim_lt :type :primitive-fun}
;; (symbol "cons") {:val prim_cons :type :primitive-fun}
;; (symbol "car") {:val prim_car :type :primitive-fun}
;; (symbol "cdr") {:val prim_cdr :type :primitive-fun}
(symbol "display") {:val prim_display :type :primitive-fun}
(symbol "write") {:val prim_write :type :primitive-fun}
:parent nil
:level 0
:def-ok? true
:tail? false
})
(defn repl
"Scheme Read-Eval-Print-Loop function"
([]
(let [boot (read-file "boot.scm")
result (eval-sequence-top
(:val boot)
global-environment)
env (:env result)]
(comment
(pprint (dissoc result :env))
(pprint env)
)
(prompt-for-input)
(repl (read-form-seq) env)))
([sseq env]
(when sseq
(let [output (eval (first sseq) env)
val (dissoc output :env)
env (:env output)]
;;(let [output (first sseq)]
;;(pprint (first sseq))
(output-prompt)
(print-exp true output)
(comment
(newline)
(pprint (:env output))
(newline)
(pprint (dissoc output :env))
)
(prompt-for-input)
(recur (rest sseq) env)))))
(repl)
;(exit)
Comments
page revision: 5, last edited: 22 May 2008 22:29
Post preview:
Close preview