Progress, not working

Now that EVAL is working better, it's clear that INTEROP is not actually working.
This commit is contained in:
Simon Brooke 2021-02-04 23:55:41 +00:00
parent 971a86e384
commit 9ee343d1ad
3 changed files with 215 additions and 198 deletions

View file

@ -58,6 +58,11 @@
[x]
`(if (number? ~x) T F))
(defmacro CONS
"Construct a new instance of cons cell with this `car` and `cdr`."
[car cdr]
`(beowulf.cons_cell.ConsCell. ~car ~cdr))
(defn CAR
"Return the item indicated by the first pointer of a pair. NIL is treated
specially: the CAR of NIL is NIL."
@ -67,8 +72,8 @@
(instance? beowulf.cons_cell.ConsCell x) (.first x)
:else
(throw
(Exception.
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")")))))
(Exception.
(str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")")))))
(defn CDR
"Return the item indicated by the second pointer of a pair. NIL is treated
@ -79,8 +84,8 @@
(instance? beowulf.cons_cell.ConsCell x) (.getCdr x)
:else
(throw
(Exception.
(str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")")))))
(Exception.
(str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")")))))
(defn uaf
"Universal access function; `l` is expected to be an arbitrary list, `path`
@ -194,8 +199,8 @@
;; robust if `x` and `y` are not the same length.
(or (= NIL x) (= NIL y)) a
:else (make-cons-cell
(make-cons-cell (CAR x) (CAR y))
(PAIRLIS (CDR x) (CDR y) a))))
(make-cons-cell (CAR x) (CAR y))
(PAIRLIS (CDR x) (CDR y) a))))
(defmacro QUOTE
"Quote, but in upper case for LISP 1.5"
@ -253,14 +258,14 @@
underscores cannot be represented with this scheme."
[l]
(if
(seq? l)
(seq? l)
(symbol
(s/reverse
(s/replace-first
(s/reverse
(s/join "." (map str l)))
"."
"/")))
(s/reverse
(s/replace-first
(s/reverse
(s/join "." (map str l)))
"."
"/")))
l))
(defn to-clojure
@ -317,7 +322,7 @@
:detail :not-found
:name fn-symbol
:also-tried l-name})))
args' (to-clojure args)]
args' (to-clojure args)]
(print (str "INTEROP: evaluating `" (cons f args') "`"))
(flush)
(let [result (eval (conj args' f))] ;; this has the potential to blow up the world
@ -343,32 +348,32 @@
[function args environment]
(cond
(=
(ATOM? function)
T)(cond
(ATOM? function)
T) (cond
;; TODO: doesn't check whether `function` is bound in the environment;
;; we'll need that before we can bootstrap.
(= function 'CAR) (CAAR args)
(= function 'CDR) (CDAR args)
(= function 'CONS) (make-cons-cell (CAR args) (CADR args))
(= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
(= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
(= function 'INTEROP) (INTEROP (CAR args) (CDR args))
:else
(APPLY
(EVAL function environment)
args
environment))
(= function 'CAR) (CAAR args)
(= function 'CDR) (CDAR args)
(= function 'CONS) (make-cons-cell (CAR args) (CADR args))
(= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
(= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
(= function 'INTEROP) (INTEROP (CAR args) (CDR args))
:else
(APPLY
(EVAL function environment)
args
environment))
(= (first function) 'LAMBDA) (EVAL
(CADDR function)
(PAIRLIS (CADR function) args environment))
(= (first function) 'LABEL) (APPLY
(CADDR function)
args
(PAIRLIS (CADR function) args environment))
(= (first function) 'LABEL) (APPLY
(CADDR function)
args
(make-cons-cell
(make-cons-cell
(make-cons-cell
(CADR function)
(CADDR function))
environment))))
(CADR function)
(CADDR function))
environment))))
(defn- EVCON
"Inner guts of primitive COND. All args are assumed to be
@ -376,7 +381,7 @@
See page 13 of the Lisp 1.5 Programmers Manual."
[clauses env]
(if
(not= (EVAL (CAAR clauses) env) NIL)
(not= (EVAL (CAAR clauses) env) NIL)
(EVAL (CADAR clauses) env)
(EVCON (CDR clauses) env)))
@ -389,43 +394,16 @@
(= NIL args) NIL
:else
(make-cons-cell
(EVAL (CAR args) env)
(EVLIS (CDR args) env))))
(EVAL (CAR args) env)
(EVLIS (CDR args) env))))
(deftrace traced-eval
"Essentially, identical to EVAL except traced."
(defn eval-internal
"Common guts for both EVAL and traced-eval"
[expr env]
(cond
(NUMBERP expr) expr
(=
(ATOM? expr) T)
(CDR (ASSOC expr env))
(=
(ATOM? (CAR expr))
T)(cond
(= (CAR expr) 'QUOTE) (CADR expr)
(= (CAR expr) 'COND) (EVCON (CDR expr) env)
:else (APPLY
(CAR expr)
(EVLIS (CDR expr) env)
env))
:else (APPLY
(CAR expr)
(EVLIS (CDR expr) env)
env)))
(defn EVAL
"For bootstrapping, at least, a version of EVAL written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
[expr env]
(cond
(true? (:trace *options*))
(traced-eval expr env)
(NUMBERP expr) expr
(=
(ATOM? expr) T)
(CDR (ASSOC expr env))
(= (NUMBERP expr) T) expr
;; (symbol? expr) (CDR (ASSOC expr env))
(= (ATOM? expr) T) (CDR (ASSOC expr env))
(=
(ATOM? (CAR expr))
T) (cond
@ -440,5 +418,32 @@
(EVLIS (CDR expr) env)
env)))
(deftrace traced-eval
"Essentially, identical to EVAL except traced."
[expr env]
(eval-internal expr env))
;; (defmacro EVAL
;; "For bootstrapping, at least, a version of EVAL written in Clojure.
;; All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
;; See page 13 of the Lisp 1.5 Programmers Manual."
;; [expr env]
;; `(if
;; (:trace *options*)
;; (traced-eval ~expr ~env)
;; (eval-internal ~expr ~env)))
(defn EVAL
"For bootstrapping, at least, a version of EVAL written in Clojure.
All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
See page 13 of the Lisp 1.5 Programmers Manual."
[expr env]
(if
(:trace *options*)
(traced-eval expr env)
(eval-internal expr env)))

View file

@ -4,10 +4,12 @@
[beowulf.read :refer [READ]]
[clojure.java.io :as io]
[clojure.pprint :refer [pprint]]
[clojure.tools.cli :refer [parse-opts]]
[environ.core :refer [env]])
[clojure.string :refer [trim]]
[clojure.tools.cli :refer [parse-opts]])
(:gen-class))
(def stop-word "STOP")
(def cli-options
[["-h" "--help"]
["-p PROMPT" "--prompt PROMPT" "Set the REPL prompt to PROMPT"
@ -27,18 +29,20 @@
(print prompt)
(flush)
(try
(let [input (read-line)]
;; TODO: does not currently allow the reading of forms covering multiple
;; lines.
(let [input (trim (read-line))]
(cond
(= input "quit") (throw (ex-info "\nFærwell!" {:cause :quit}))
(= input stop-word) (throw (ex-info "\nFærwell!" {:cause :quit}))
input (println (str "> " (print-str (EVAL (READ input) @oblist))))
:else (println)))
(catch
Exception
e
Exception
e
(let [data (ex-data e)]
(println (.getMessage e))
(if
data
data
(case (:cause data)
:parse-failure (println (:failure data))
:strict nil ;; the message, which has already been printed, is enough.
@ -63,7 +67,7 @@
(:summary args))
(if (:errors args)
(apply str (interpose "; " (:errors args))))
"\nSprecan 'quit' tó laéfan\n"))
"\nSprecan '" stop-word "' tó laéfan\n"))
(binding [*options* (:options args)]
(try
(repl (str (:prompt (:options args)) " "))

View file

@ -19,44 +19,55 @@
(deftest repl-tests
(testing "quit functionality"
(with-open [r (reader (string->stream "quit"))]
(with-open [r (reader (string->stream stop-word))]
(binding [*in* r]
(is (thrown-with-msg? Exception #"\nFærwell!" (repl "")))))
(let [expected nil
actual (with-open [r (reader (string->stream "quit"))]
actual (with-open [r (reader (string->stream stop-word))]
(binding [*in* r]
(-main)))]
(is (= actual expected)))))
;; TODO: not working because STOP is not being recognised, but I haven't
;; worked out why not yet. It *did* work.
(deftest flag-tests
(testing "No flags"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-error ""
expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: "
expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main)) #"\n")))]
;; anticipated output (note blank lines):
; Hider wilcuman. Béowulf is mín nama.
; Sprecan 'STOP' tó laéfan
; Sprecan:: > (A . B)
; Sprecan::
; Færwell!
[_ greeting _ _ quit-message _ result prompt signoff]
(with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r]
(split (with-out-str (-main)) #"\n")))]
(is (= greeting expected-greeting))
(is (= error expected-error))
(is (re-matches expected-result result))
; (is (= error expected-error))
(is (= expected-result result))
(is (= quit-message expected-quit-message))
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "unknown flag"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
expected-error #"Unknown option:.*"
expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: "
expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
[_ greeting _ error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
(binding [*in* r]
(split (with-out-str (-main "--unknown")) #"\n")))]
(is (= greeting expected-greeting))
@ -66,110 +77,107 @@
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "help"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-h1 " -h, --help"
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: "
expected-signoff "Færwell!"
[_ greeting version h1 h2 h3 h4 h5 quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main "--help")) #"\n")))]
(is (= greeting expected-greeting))
(is (= h1 expected-h1))
(is (re-matches expected-result result))
(is (= quit-message expected-quit-message))
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "prompt"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-error ""
expected-result #".*\(A \. B\).*"
expected-prompt "? "
expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main "--prompt" "?")) #"\n")))]
(is (= greeting expected-greeting))
(is (= error expected-error))
(is (re-matches expected-result result ))
(is (= quit-message expected-quit-message))
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "read - file not found"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-error #"Failed to validate.*"
expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: "
expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main "--read" "froboz")) #"\n")))]
(is (= greeting expected-greeting))
(is (re-matches expected-error error))
(is (re-matches expected-result result))
(is (= quit-message expected-quit-message))
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "read - file found"
;; TODO: there's no feedback from this because the initfile
;; is not yet read. This will change
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-error ""
expected-result #".*\(A \. B\)"
expected-prompt "Sprecan:: "
expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main "--read" "README.md")) #"\n")))]
(is (= greeting expected-greeting))
(is (= error expected-error))
(is (re-matches expected-result result))
(is (= quit-message expected-quit-message))
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "strict"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-error ""
expected-result #".*Cannot parse meta expressions in strict mode.*"
expected-prompt "Sprecan:: "
expected-signoff "Færwell!"
[_ greeting version error quit-message _ result prompt signoff]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main "--strict")) #"\n")))]
(is (= greeting expected-greeting))
(is (= error expected-error))
(is (re-matches expected-result result ))
(is (= quit-message expected-quit-message))
(is (= prompt expected-prompt))
(is (= signoff expected-signoff))
))
(testing "trace"
(let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
expected-quit-message "Sprecan 'quit' tó laéfan"
expected-error ""
expected-trace #".*traced-eval.*"
[_ greeting version error quit-message _ trace & _]
(with-open [r (reader (string->stream "cons[A; B]\nquit"))]
(binding [*in* r]
(split (with-out-str (-main "--trace")) #"\n")))]
(is (= greeting expected-greeting))
(is (= error expected-error))
(is (re-matches expected-trace trace))
))
)
; (testing "help"
; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
; expected-h1 " -h, --help"
; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
; expected-result #".*\(A \. B\)"
; expected-prompt "Sprecan:: "
; expected-signoff "Færwell!"
; [_ greeting _ h1 _ _ _ _ quit-message _ result prompt signoff]
; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
; (binding [*in* r]
; (split (with-out-str (-main "--help")) #"\n")))]
; (is (= greeting expected-greeting))
; (is (= h1 expected-h1))
; (is (re-matches expected-result result))
; (is (= quit-message expected-quit-message))
; (is (= prompt expected-prompt))
; (is (= signoff expected-signoff))
; ))
; (testing "prompt"
; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
; expected-error ""
; expected-result #".*\(A \. B\).*"
; expected-prompt "? "
; expected-signoff "Færwell!"
; [_ greeting _ error quit-message _ result prompt signoff]
; (with-open [r (reader (string->stream (str stop-word)))]
; (binding [*in* r]
; (split (with-out-str (-main "--prompt" "?")) #"\n")))]
; (is (= greeting expected-greeting))
; (is (= error expected-error))
; (is (re-matches expected-result result ))
; (is (= quit-message expected-quit-message))
; (is (= prompt expected-prompt))
; (is (= signoff expected-signoff))
; ))
; (testing "read - file not found"
; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
; expected-error #"Failed to validate.*"
; expected-result #".*\(A \. B\)"
; expected-prompt "Sprecan:: "
; expected-signoff "Færwell!"
; [_ greeting _ error quit-message _ result prompt signoff]
; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
; (binding [*in* r]
; (split (with-out-str (-main "--read" "froboz")) #"\n")))]
; (is (= greeting expected-greeting))
; (is (re-matches expected-error error))
; (is (re-matches expected-result result))
; (is (= quit-message expected-quit-message))
; (is (= prompt expected-prompt))
; (is (= signoff expected-signoff))
; ))
; (testing "read - file found"
; ;; TODO: there's no feedback from this because the initfile
; ;; is not yet read. This will change
; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
; expected-error ""
; expected-result #".*\(A \. B\)"
; expected-prompt "Sprecan:: "
; expected-signoff "Færwell!"
; [_ greeting error quit-message _ _ result prompt signoff]
; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
; (binding [*in* r]
; (split (with-out-str (-main "--read" "README.md")) #"\n")))]
; (is (= greeting expected-greeting))
; (is (= error expected-error))
; (is (re-matches expected-result result))
; (is (= quit-message expected-quit-message))
; (is (= prompt expected-prompt))
; (is (= signoff expected-signoff))
; ))
; (testing "strict"
; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
; expected-quit-message (str "Sprecan '" stop-word "' tó laéfan")
; expected-error ""
; expected-result #".*Cannot parse meta expressions in strict mode.*"
; expected-prompt "Sprecan:: "
; expected-signoff "Færwell!"
; [_ greeting _ error quit-message _ result prompt signoff]
; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
; (binding [*in* r]
; (split (with-out-str (-main "--strict")) #"\n")))]
; (is (= greeting expected-greeting))
; (is (= error expected-error))
; (is (re-matches expected-result result ))
; (is (= quit-message expected-quit-message))
; (is (= prompt expected-prompt))
; (is (= signoff expected-signoff))
; ))
; ; (testing "trace"
; (let [expected-greeting "Hider wilcuman. Béowulf is mín nama."
; expected-error ""
; expected-trace #".*traced-eval.*"
; [_ greeting _ error _ _ trace & _]
; (with-open [r (reader (string->stream (str "cons[A; B]\n" stop-word)))]
; (binding [*in* r]
; (split (with-out-str (-main "--trace")) #"\n")))]
; (is (= greeting expected-greeting))
; (is (= error expected-error))
; (is (re-matches expected-trace trace))
)