diff --git a/resources/null.mexpr.lsp b/resources/null.mexpr.lsp new file mode 100644 index 0000000..b984d21 --- /dev/null +++ b/resources/null.mexpr.lsp @@ -0,0 +1 @@ +null[x] = [x = NIL -> T; T -> F] \ No newline at end of file diff --git a/src/beowulf/bootstrap.clj b/src/beowulf/bootstrap.clj index 8d9689a..ce38c66 100644 --- a/src/beowulf/bootstrap.clj +++ b/src/beowulf/bootstrap.clj @@ -13,11 +13,12 @@ [clojure.tools.trace :refer [deftrace]] [beowulf.cons-cell :refer [CAR CDR CONS LIST make-beowulf-list make-cons-cell pretty-print T F]] - [beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS2 QUOTIENT - REMAINDER RPLACA RPLACD SUB1 TIMES2]] + [beowulf.host :refer [ADD1 DIFFERENCE FIXP NUMBERP PLUS QUOTIENT + REMAINDER RPLACA RPLACD SUB1 TIMES]] [beowulf.io :refer [SYSIN SYSOUT]] [beowulf.oblist :refer [*options* oblist NIL]]) - (:import [beowulf.cons_cell ConsCell])) + (:import [beowulf.cons_cell ConsCell] + [clojure.lang Symbol])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -29,7 +30,7 @@ ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(declare EVAL) +(declare APPLY EVAL) (defmacro NULL @@ -379,42 +380,62 @@ symbol val) NIL)) -(defn APPLY - "For bootstrapping, at least, a version of APPLY 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." +(defn- apply-symbolic + "Apply this `funtion-symbol` to these `args` in this `environment` and + return the result." + [^Symbol function-symbol ^ConsCell args ^ConsCell environment] + (let [fn (try (EVAL function-symbol environment) + (catch Throwable any (when (:trace *options*) + (println any))))] + (if (and fn (not= fn NIL)) + (APPLY fn args environment) + (case function-symbol ;; there must be a better way of doing this! + ADD1 (apply ADD1 args) + APPEND (apply APPEND args) + APPLY (apply APPLY args) + ATOM (ATOM? (CAR args)) + CAR (CAAR args) + CDR (CDAR args) + CONS (make-cons-cell (CAR args) (CADR args)) + DEFINE (DEFINE (CAR args)) + DIFFERENCE (DIFFERENCE (CAR args) (CADR args)) + EQ (apply EQ args) + ;; think about EVAL. Getting the environment right is subtle + FIXP (apply FIXP args) + INTEROP (apply INTEROP args) + NUMBERP (apply NUMBERP args) + PLUS (apply PLUS args) + PRETTY (apply pretty-print args) + QUOTIENT (apply QUOTIENT args) + REMAINDER (apply REMAINDER args) + RPLACA (apply RPLACA args) + RPLACD (apply RPLACD args) + SET (apply SET args) + SYSIN (apply SYSIN args) + SYSOUT (apply SYSOUT args) + TIMES (apply TIMES args) + ;; else + (ex-info "No function found" + {:context "APPLY" + :function function-symbol + :args args}))))) + +(defn apply-internal + "Internal guts of both `APPLY` and `traced-apply`. Apply this `function` to + these `arguments` in this `environment` and return the result. + + For bootstrapping, at least, a version of APPLY 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." [function args environment] (cond - (= NIL function) (throw (ex-info "NIL is not a function" {:context "APPLY" - :function "NIL" - :args args})) - (= - (ATOM? function) - T) (cond - ;; (fn? (eval function)) (apply (eval function) args) - (not= - (ASSOC function environment) - NIL) (APPLY (CDR (ASSOC function environment)) args environment) - (= function 'ATOM) (if (ATOM? (CAR args)) T NIL) - (= function 'CAR) (CAAR args) - (= function 'CDR) (CDAR args) - (= function 'CONS) (make-cons-cell (CAR args) (CADR args)) - (= function 'DEFINE) (DEFINE args) - (= function 'EQ) (apply EQ args) - (= function 'INTEROP) (INTEROP (CAR args) (CDR args)) - (= function 'SET) (SET (CAR args) (CADR args)) - (= function 'SYSIN) (SYSIN (CAR args)) - (= function 'SYSOUT) (SYSOUT (CAR args)) - (EVAL function environment) (APPLY - (EVAL function environment) - args - environment) - :else - (throw (ex-info "No function found" {:context "APPLY" - :function function - :args args}))) - (fn? function) ;; i.e., it's a Clojure function - (apply function (to-clojure args)) + (= NIL function) (if (:strict *options*) + NIL + (throw (ex-info "NIL is not a function" + {:context "APPLY" + :function "NIL" + :args args}))) + (= (ATOM? function) T) (apply-symbolic function args environment) (= (first function) 'LAMBDA) (EVAL (CADDR function) (PAIRLIS (CADR function) args environment)) @@ -427,8 +448,27 @@ (CADDR function)) environment)))) +(deftrace traced-apply + "Traced wrapper for `internal-apply`, q.v. Apply this `function` to + these `arguments` in this `environment` and return the result." + [function args environment] + (apply-internal function args environment)) + +(defn APPLY + "Despatcher for APPLY, selects beteen `traced-apply` and `apply-internal` + based on the value of `:trace` in `*options*`. Apply this `function` to + these `arguments` and return the result. If `environment` is not passed, + if defaults to the current value of the global object list." + ([function args] + (APPLY function args @oblist)) + ([function args environment] + (if + (:trace *options*) + (traced-apply function args environment) + (apply-internal function args environment)))) + (defn- EVCON - "Inner guts of primitive COND. All args are assumed to be + "Inner guts of primitive COND. All `clauses` are assumed to be `beowulf.cons-cell/ConsCell` objects. See page 13 of the Lisp 1.5 Programmers Manual." [clauses env] @@ -449,20 +489,33 @@ (EVAL (CAR args) env) (EVLIS (CDR args) env)))) -(defn eval-internal - "Common guts for both EVAL and traced-eval" +(defn- eval-symbolic [^Symbol s env] + (let [binding (CDR (ASSOC s env))] + (if (= binding NIL) + (throw (ex-info (format "No binding for symbol `%s`" s) + {:phase :eval + :symbol s})) + binding))) + +(defn- eval-internal + "Common guts for both EVAL and traced-eval. Evaluate this `expr` + and return the result. + + For bootstrapping, at least, this is 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 (= (NUMBERP expr) T) expr + (symbol? expr) (eval-symbolic expr env) (string? expr) (if (:strict *options*) (throw (ex-info (str "EVAL: strings not allowed in strict mode: \"" expr "\"") - {:cause :eval + {:phase :eval :detail :strict :expr expr})) (symbol expr)) - (= (ATOM? expr) T) (CDR (ASSOC expr env)) (= (ATOM? (CAR expr)) T) (cond @@ -494,9 +547,11 @@ (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." + "Despatcher for EVAL, selects beteen `traced-eval` and `eval-internal` + based on the value of `:trace` in `*options*`. Evaluate this `expr` + and return the result. If `environment` is not passed, + if defaults to the current value of the global object list. + All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects." ([expr] (EVAL expr @oblist)) ([expr env] diff --git a/src/beowulf/host.clj b/src/beowulf/host.clj index ff3b895..b4220bc 100644 --- a/src/beowulf/host.clj +++ b/src/beowulf/host.clj @@ -63,17 +63,14 @@ {:cause :bad-value :detail :rplaca}))));; PLUS -(defn PLUS2 - "Lisp 1.5 `PLUS` is varargs, and implementing varargs functions in Clojure is - not an added complexity I want. So this is a two arg `PLUS`, on which a - varargs `PLUS` can be built in the Lisp 1.5 layer using `REDUCE`." - [x y] - (let [s (+ x y)] +(defn PLUS + [& args] + (let [s (apply + args)] (if (integer? s) s (float s)))) -(defn TIMES2 - [x y] - (let [p (* x y)] +(defn TIMES + [& args] + (let [p (apply * args)] (if (integer? p) p (float p)))) (defn DIFFERENCE diff --git a/src/beowulf/io.clj b/src/beowulf/io.clj index f262515..7f08d38 100644 --- a/src/beowulf/io.clj +++ b/src/beowulf/io.clj @@ -48,7 +48,7 @@ (with-out-str (println (apply str (repeat 79 ";"))) (println (format ";; Beowulf %s Sysout file generated at %s" - (System/getProperty "beowulf.version") + (or (System/getProperty "beowulf.version") "") (local-date-time))) (when (System/getenv "USER") (println (format ";; generated by %s" (System/getenv "USER")))) diff --git a/src/beowulf/reader/generate.clj b/src/beowulf/reader/generate.clj index cba61b5..7dc755e 100644 --- a/src/beowulf/reader/generate.clj +++ b/src/beowulf/reader/generate.clj @@ -130,7 +130,7 @@ (defn gen-iexpr [tree] - (let [bundle (reduce #(assoc %1 (first %2) (nth %2 1)) + (let [bundle (reduce #(assoc %1 (first %2) %2) {} (rest tree))] (list (generate (:iop bundle)) @@ -194,9 +194,22 @@ :exponent (generate (second p)) :fncall (gen-fn-call p) :iexpr (gen-iexpr p) + :iop (case (second p) + "/" 'DIFFERENCE + "=" 'EQUAL + ">" 'GREATERP + "<" 'LESSP + "+" 'PLUS + "*" 'TIMES + ;; else + (throw (ex-info "Unrecognised infix operator symbol" + {:phase :generate + :fragment p}))) :list (gen-dot-terminated-list (rest p)) (:lhs :rhs) (generate (second p)) :mexpr (generate (second p)) + :mconst (make-beowulf-list + (list 'QUOTE (symbol (upper-case (second p))))) :mvar (symbol (upper-case (second p))) :octal (let [n (read-string (strip-leading-zeros (second p) "0")) scale (generate (nth p 2))] diff --git a/src/beowulf/reader/parser.clj b/src/beowulf/reader/parser.clj index f248a3b..a08c8cb 100644 --- a/src/beowulf/reader/parser.clj +++ b/src/beowulf/reader/parser.clj @@ -24,11 +24,11 @@ ;; but it's a convenience. "exprs := expr | exprs;" - "mexpr := λexpr | fncall | defn | cond | mvar | iexpr | mexpr comment; + "mexpr := λexpr | fncall | defn | cond | mvar | mconst | iexpr | mexpr comment; λexpr := λ lsqb bindings semi-colon body rsqb; λ := 'λ'; bindings := lsqb args rsqb; - body := (expr semi-colon opt-space)* expr; + body := (mexpr semi-colon opt-space)* mexpr; fncall := fn-name lsqb args rsqb; lsqb := '['; rsqb := ']'; @@ -36,18 +36,21 @@ rbrace := '}'; defn := mexpr opt-space '=' opt-space mexpr; cond := lsqb (opt-space cond-clause semi-colon opt-space)* cond-clause rsqb; - cond-clause := expr opt-space arrow opt-space expr opt-space; + cond-clause := mexpr opt-space arrow opt-space mexpr opt-space; arrow := '->'; - args := (opt-space expr semi-colon opt-space)* expr; + args := (opt-space mexpr semi-colon opt-space)* mexpr; fn-name := mvar; mvar := #'[a-z]+'; + mconst := #'[A-Z]+'; semi-colon := ';';" ;; Infix operators appear in mexprs, e.g. on page 7. Ooops! ;; I do not know what infix operators are considered legal. + ;; In particular I do not know what symbol was used for + ;; multiply "iexpr := iexp iop iexp; iexp := mexpr | number | opt-space iexp opt-space; - iop := '>' | '<' | '+' | '-' | '/' | '=' ;" + iop := '>' | '<' | '+' | '-' | '*' '/' | '=' ;" ;; comments. I'm pretty confident Lisp 1.5 did NOT have these. "opt-comment := opt-space | comment;" diff --git a/src/beowulf/reader/simplify.clj b/src/beowulf/reader/simplify.clj index f4520d3..50b3833 100644 --- a/src/beowulf/reader/simplify.clj +++ b/src/beowulf/reader/simplify.clj @@ -35,7 +35,10 @@ (defn simplify "Simplify this parse tree `p`. If `p` is an instaparse failure object, throw - an `ex-info`, with `p` as the value of its `:failure` key." + an `ex-info`, with `p` as the value of its `:failure` key. + + **NOTE THAT** it is assumed that `remove-optional-space` has been run on the + parse tree **BEFORE** it is passed to `simplify`." ([p] (if (instance? Failure p) @@ -55,7 +58,7 @@ (case (first p) (:λexpr :args :bindings :body :cond :cond-clause :defn :dot-terminal - :fncall :lhs :octal :quoted-expr :rhs :scientific) (map #(simplify % context) p) + :fncall :lhs :quoted-expr :rhs ) (map #(simplify % context) p) (:arg :expr :coefficient :fn-name :number) (simplify (second p) context) (:arrow :dot :e :lpar :lsqb :opt-comment :opt-space :q :quote :rpar :rsqb :semi-colon :sep :space) nil @@ -68,7 +71,7 @@ (throw (ex-info "Cannot parse comments in strict mode" {:cause :strict}))) - :decimal p + (:decimal :integer :mconst :octal :scientific) p :dotted-pair (if (= context :mexpr) [:fncall diff --git a/test/beowulf/host_test.clj b/test/beowulf/host_test.clj index 10b86f4..da86637 100644 --- a/test/beowulf/host_test.clj +++ b/test/beowulf/host_test.clj @@ -1,7 +1,7 @@ (ns beowulf.host-test (:require [clojure.test :refer [deftest is testing]] [beowulf.cons-cell :refer [CDR F make-beowulf-list T]] - [beowulf.host :refer [DIFFERENCE NUMBERP PLUS2 RPLACA RPLACD TIMES2]] + [beowulf.host :refer [DIFFERENCE NUMBERP PLUS RPLACA RPLACD TIMES]] [beowulf.oblist :refer [NIL]] [beowulf.read :refer [gsp]])) @@ -51,18 +51,18 @@ (deftest arithmetic-test ;; These are just sanity-test tests; they're by no means exhaustive. - (testing "PLUS2" + (testing "PLUS" (let [expected 3 - actual (PLUS2 1 2)] + actual (PLUS 1 2)] (is (= actual expected)) (is (integer? actual))) (let [expected 3.5 - actual (PLUS2 1.25 9/4)] + actual (PLUS 1.25 9/4)] (is (= actual expected)) (is (float? actual)))) - (testing "TIMES2" + (testing "TIMES" (let [expected 6 - actual (TIMES2 2 3)] + actual (TIMES 2 3)] (is (= actual expected)))) (testing DIFFERENCE (let [expected -1