From 12bbd0076a737f94e88603b996b3d919c8c5a8a5 Mon Sep 17 00:00:00 2001 From: Simon Brooke Date: Thu, 15 Aug 2019 21:14:17 +0100 Subject: [PATCH] Read works, print works, eval is horribly broken. --- project.clj | 1 + resources/bootstrap.lsp | 2 + src/beowulf/cons_cell.clj | 4 +- src/beowulf/core.clj | 12 +- src/beowulf/eval.clj | 288 ++++++++++++++++++++++++++++++++++++-- src/beowulf/functions.clj | 32 ----- src/beowulf/print.clj | 6 + src/beowulf/read.clj | 3 + 8 files changed, 299 insertions(+), 49 deletions(-) create mode 100644 resources/bootstrap.lsp delete mode 100644 src/beowulf/functions.clj diff --git a/project.clj b/project.clj index 661f0ce..3985efa 100644 --- a/project.clj +++ b/project.clj @@ -5,6 +5,7 @@ :url "https://www.eclipse.org/legal/epl-2.0/"} :dependencies [[org.clojure/clojure "1.10.0"] [org.clojure/math.numeric-tower "0.0.4"] + [org.clojure/tools.trace "0.7.10"] [instaparse "1.4.10"]] :main ^:skip-aot beowulf.core :target-path "target/%s" diff --git a/resources/bootstrap.lsp b/resources/bootstrap.lsp new file mode 100644 index 0000000..fdbfa2e --- /dev/null +++ b/resources/bootstrap.lsp @@ -0,0 +1,2 @@ +(COMMENT '(THIS FILE WILL CONTAIN FUNCTION DEFINITIONS TO BOOTSTRAP LISP FULLSTOP + AT PRESENT WE HAVE NO COMMENT SYNTAX)) diff --git a/src/beowulf/cons_cell.clj b/src/beowulf/cons_cell.clj index 2bbb5e4..2a299d5 100644 --- a/src/beowulf/cons_cell.clj +++ b/src/beowulf/cons_cell.clj @@ -3,7 +3,9 @@ (def NIL (symbol "NIL")) -(def NIL (symbol "NIL")) +(def T (symbol "T")) ;; true. + +(def F (symbol "F")) ;; false as distinct from nil (deftype ConsCell [CAR CDR] clojure.lang.ISeq diff --git a/src/beowulf/core.clj b/src/beowulf/core.clj index 14e4b50..a0644df 100644 --- a/src/beowulf/core.clj +++ b/src/beowulf/core.clj @@ -1,7 +1,17 @@ (ns beowulf.core + (:require [beowulf.eval :refer [primitive-eval oblist]] + [beowulf.read :refer [primitive-read]] + [beowulf.print :refer [primitive-print prin]]) (:gen-class)) (defn -main "I don't do a whole lot ... yet." [& args] - (println "Hello, World!")) + (println "Hello, World!") + (loop [] + (print ":: ") + (flush) + (let [input (primitive-read)] + (println (str "\tI read: " (prin input))) + (println (str "> "(prin (primitive-eval input @oblist)))) + (recur)))) diff --git a/src/beowulf/eval.clj b/src/beowulf/eval.clj index 22afe71..97fbf1a 100644 --- a/src/beowulf/eval.clj +++ b/src/beowulf/eval.clj @@ -1,25 +1,283 @@ (ns beowulf.eval - (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL]])) + (:require [clojure.tools.trace :refer :all] + [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]])) -(declare *oblist* primitive-eval) +(declare primitive-eval) +(def oblist + "The default environment; modified certainly be `LABEL` (which seems to + be Lisp 1.5's equivalent of `SETQ`), possibly by other things." + (atom NIL)) - -(defn primitive-eval +(defn null [x] + (= x NIL)) + +(defn primitive-atom + "It is not clear to me from the documentation whether `(ATOM 7)` should return + `'T` or `'F`. I'm going to assume `'T`." + [x] + (if (or (symbol? x) (number? x)) 'T 'F)) + +(defn primitive-atom? + "The convention of returning `'F` from predicates, rather than `NIL`, is going + to tie me in knots. This is a variant of `primitive-atom` which returns `NIL` + on failure." + [x] + (if (or (symbol? x) (number? x)) 'T NIL)) + +(defn car + [x] + (if + (instance? beowulf.cons_cell.ConsCell x) + (.CAR x) + NIL)) + +(defn cdr + [x] + (if + (instance? beowulf.cons_cell.ConsCell x) + (.CDR x) + NIL)) + +(defn uaf + "Universal access function; `l` is expected to be an arbitrary list, `path` + a (clojure) list of the characters `a` and `d`. Intended to make declaring + all those fiddly `#'c[ad]+r'` functions a bit easier" + [l path] (cond - (number? x) x - (symbol? x) (@*oblist* x) - (instance? x beowulf.cons_cell.ConsCell) - (apply (primitive-eval (.CAR x)) (map primitive-eval (.CDR x))) + (null l) NIL + (not (instance? beowulf.cons_cell.ConsCell l)) + (throw (Exception. (str "Unexpected list argument to uaf: `" l "`"))) + (empty? (rest path))(case (first path) + \a (car l) + \d (cdr l)) + :else (case (first path) + \a (uaf (car l) (rest path)) + \d (uaf (cdr l) (rest path))))) + +(defn caar [x] (uaf x (seq "aa"))) +(defn cadr [x] (uaf x (seq "ad"))) +(defn cddr [x] (uaf x (seq "dd"))) +(defn cdar [x] (uaf x (seq "da"))) + +(defn caaar [x] (uaf x (seq "aaa"))) +(defn caadr [x] (uaf x (seq "aad"))) +(defn cadar [x] (uaf x (seq "ada"))) +(defn caddr [x] (uaf x (seq "add"))) +(defn cddar [x] (uaf x (seq "dda"))) +(defn cdddr [x] (uaf x (seq "ddd"))) +(defn cdaar [x] (uaf x (seq "daa"))) +(defn cdadr [x] (uaf x (seq "dad"))) + +(defn caaaar [x] (uaf x (seq "aaaa"))) +(defn caadar [x] (uaf x (seq "aada"))) +(defn cadaar [x] (uaf x (seq "adaa"))) +(defn caddar [x] (uaf x (seq "adda"))) +(defn cddaar [x] (uaf x (seq "ddaa"))) +(defn cdddar [x] (uaf x (seq "ddda"))) +(defn cdaaar [x] (uaf x (seq "daaa"))) +(defn cdadar [x] (uaf x (seq "dada"))) +(defn caaadr [x] (uaf x (seq "aaad"))) +(defn caaddr [x] (uaf x (seq "aadd"))) +(defn cadadr [x] (uaf x (seq "adad"))) +(defn cadddr [x] (uaf x (seq "addd"))) +(defn cddadr [x] (uaf x (seq "ddad"))) +(defn cddddr [x] (uaf x (seq "dddd"))) +(defn cdaadr [x] (uaf x (seq "daad"))) +(defn cdaddr [x] (uaf x (seq "dadd"))) + +;; (defn eq +;; "`eq` is only defined for atoms (symbols); it is NOT pointer identity, as +;; it is in later Lisps. Returns `'T` on success (identical atoms), `'F` +;; (NOT `NIL`) on failure. The behaviour if either argument is not an atom is +;; stated to be 'undefined', but I shall return `'F` for consistency."I +;; [x y] +;; (cond +;; (and (primitive-atom? x) (= x y)) 'T +;; :else +;; 'F)) + +(defn eq [x y] (if (and (primitive-atom? x) (= x y)) T F)) + +(defn equal + "This is a predicate that is true if its two arguments are identical + S-expressions, and false if they are different. (The elementary predicate + `eq` is defined only for atomic arguments.) The definition of `equal` is + an example of a conditional expression inside a conditional expression." + [x y] + (cond + (primitive-atom? x) (cond + (primitive-atom? y) (eq x y) + :else 'F) ;; NOTE: returns F on failure, not NIL + (equal (car x) (car y)) (equal (cdr x) (cdr y)) + :else 'F)) + +(defn subst + "This function gives the result of substituting the S-expression `x` for + all occurrences of the atomic symbol `y` in the S-expression `z`." + [x y z] + (cond + (equal y z) x + (primitive-atom? z) z ;; NIL is a symbol :else - (throw (Exception. (str "Don't know how to eval `" x "`"))))) + (make-cons-cell (subst x y (car z)) (subst x y (cdr z))))) + +(defn append + "Append the the elements of `y` to the elements of `x`. + + All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + See page 11 of the Lisp 1.5 Programmers Manual." + [x y] + (cond + (null x) y + :else + (cons (car x) (append (cdr x) y)))) -(def ^:dynamic *oblist* - "The base environment." - (atom {'NIL NIL - 'F NIL - 'T 'T - 'eval primitive-eval})) +(defn member + "This predicate is true if the S-expression `x` occurs among the elements + of the list `y`. + + All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. + See page 11 of the Lisp 1.5 Programmers Manual." + [x y] + (cond + (= y NIL) F ;; NOTE: returns F on falsity, not NIL + (equal x (car y)) T + :else (member x (cdr y)))) + +(defn pairlis + "This function gives the list of pairs of corresponding elements of the + lists `x` and `y`, and appends this to the list `a`. The resultant list + of pairs, which is like a table with two columns, is called an + association list. + + Eessentially, it builds the environment on the stack, implementing shallow + binding. + + All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + See page 12 of the Lisp 1.5 Programmers Manual." + [x y a] + (cond + ;; the original tests only x; testing y as well will be a little more + ;; robust if `x` and `y` are not the same length. + (or (null x) (null y)) a + :else (make-cons-cell + (make-cons-cell (car x) (car y)) + (pairlis (cdr x) (cdr y) a)))) + +(defn primitive-assoc + "If a is an association list such as the one formed by pairlis in the above + example, then assoc will produce the first pair whose first term is x. Thus + it is a table searching function. + + All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + See page 12 of the Lisp 1.5 Programmers Manual." + [x a] + (cond + (null a) NIL ;; this clause is not present in the original but is added for + ;; robustness. + (equal (caar a) x) (car a) + :else + (primitive-assoc x (cdr a)))) + +(defn- sub2 + "Internal to `sublis`, q.v., which substitutes into a list from a store. + ? I think this is doing variable binding in the stack frame?" + [a z] + (cond + (null a) z + (= (caar a) z) (cdar a) + :else + (sub2 (cdr a) z))) + +(defn sublis + "Here `a` is assumed to be an association list of the form + `((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any + S-expression. What `sublis` does, is to treat the `u`s as variables when + they occur in `y`, and to substitute the corresponding `v`s from the pair + list. + + My interpretation is that this is variable binding in the stack frame. + + All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + See page 12 of the Lisp 1.5 Programmers Manual." + [a y] + (cond + (primitive-atom? y) (sub2 a y) + :else + (make-cons-cell (sublis a (car y)) (sublis a (cdr y))))) + +(deftrace primitive-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." + [function args environment] + (cond + (primitive-atom? function)(cond + (= function 'CAR) (caar args) + (= function 'CDR) (cdar args) + (= function 'CONS) (make-cons-cell (car args) (cadr args)) + (= function 'ATOM) (if (primitive-atom? (car args)) T NIL) + (= function 'EQ) (if (= (car args) (cadr args)) T NIL) + :else + (primitive-apply + (primitive-eval function environment) + args + environment)) + (= (first function) 'LAMBDA) (primitive-eval + (caddr function) + (pairlis (cadr function) args environment)) + (= (first function) 'LABEL) (primitive-apply + (caddr function) + args + (make-cons-cell + (make-cons-cell + (cadr function) + (caddr function)) + environment)))) + +(defn- evcon + "Inner guts of primitive COND. All args are assumed to be + `beowulf.cons-cell/ConsCell` objects. + See page 13 of the Lisp 1.5 Programmers Manual." + [clauses env] + (cond + (not= (primitive-eval (caar clauses) env) NIL) + (primitive-eval (cadar clauses) env) + :else + (evcon (cdr clauses) env))) + +(defn- evlis + "Map `primitive-eval` across this list of `args` in the context of this + `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + See page 13 of the Lisp 1.5 Programmers Manual." + [args env] + (cond + (null args) NIL + :else + (make-cons-cell + (primitive-eval (car args) env) + (evlis (cdr args) env)))) + + +(deftrace primitive-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 + (primitive-atom? expr) (cdr (primitive-assoc expr env)) + (primitive-atom? (car expr))(cond + (eq (car expr) 'QUOTE) (cadr expr) + (eq (car expr) 'COND) (evcon (cdr expr) env) + :else (primitive-apply + (car expr) + (evlis (cdr expr) env) + env)) + :else (primitive-apply + (car expr) + (evlis (cdr expr) env) + env))) diff --git a/src/beowulf/functions.clj b/src/beowulf/functions.clj deleted file mode 100644 index bbf3b6d..0000000 --- a/src/beowulf/functions.clj +++ /dev/null @@ -1,32 +0,0 @@ -(ns beowulf.functions - (:require [beowulf.read :as r] - [beowulf.print :as p]) - ) - -(defn car - [sexpr] - (if - (list? sexpr) - (first sexpr) - (throw (Exception. "Undefined: car[" (p/prin sexpr) "]")))) - -(defn cdr - [sexpr] - (if - (list? sexpr) - (rest sexpr) - (throw (Exception. "Undefined: cdr[" (p/prin sexpr) "]")))) - -(defn eq - "eq, in LISP 1.5, is equality of atoms, only." - [a b] - (if - (and (symbol? a)(symbol? b)) - (= a b) - (throw (Exception. "Undefined: eq[" (p/prn a) ";" (p/prn b) "]")))) - -(defn atom - [sexpr] - (symbol? sexpr)) - - diff --git a/src/beowulf/print.clj b/src/beowulf/print.clj index 5c8c196..e9b1835 100644 --- a/src/beowulf/print.clj +++ b/src/beowulf/print.clj @@ -51,3 +51,9 @@ [x] (str x))) +(defn primitive-print + [x] + (if + (satisfies? beowulf.print.Printable x) (prin x) + (str x))) + diff --git a/src/beowulf/read.clj b/src/beowulf/read.clj index 0551be7..6b83b84 100644 --- a/src/beowulf/read.clj +++ b/src/beowulf/read.clj @@ -266,3 +266,6 @@ (throw (Exception. (str "Cannot yet generate " (first p))))) p)) +(defn primitive-read + [] + (generate (simplify (parse (read-line)))))