simon/beowulf
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Progress, not working

Browse source 
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
Show stats Download patch file Download diff file Expand all files Collapse all files

145
src/beowulf/bootstrap.clj
View file

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

20
src/beowulf/core.clj
View file

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

248
test/beowulf/core_test.clj
View file

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