diff --git a/.gitignore b/.gitignore index d18f225..5903fe9 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,5 @@ pom.xml.asc /.nrepl-port .hgignore .hg/ +.idea/ +*~ diff --git a/README.md b/README.md index 5066abe..56ed168 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # beowulf -LISP 1.5 is to all Lisp dialects as Beowulf is to Emglish literature. +LISP 1.5 is to all Lisp dialects as Beowulf is to English literature. ## What this is @@ -13,6 +13,10 @@ same bahaviour - except as documented below. Boots to REPL, but few functions yet available. +* [Project website](https://simon-brooke.github.io/beowulf/). +* [Source code documentation](https://simon-brooke.github.io/beowulf/docs/codox/index.html). +* [Test Coverage Report](https://simon-brooke.github.io/beowulf/docs/cloverage/index.html) + ### Architectural plan Not everything documented in this section is yet built. It indicates the diff --git a/beowulf.iml b/beowulf.iml new file mode 100644 index 0000000..62bb49e --- /dev/null +++ b/beowulf.iml @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/cloverage/beowulf/bootstrap.clj.html b/docs/cloverage/beowulf/bootstrap.clj.html index b8944e7..20afabb 100644 --- a/docs/cloverage/beowulf/bootstrap.clj.html +++ b/docs/cloverage/beowulf/bootstrap.clj.html @@ -38,910 +38,910 @@ 011    objects."
- 012    (:require [clojure.tools.trace :refer :all] + 012    (:require [clojure.string :as s]
- 013              [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]])) + 013              [clojure.tools.trace :refer :all] +
+ + 014              [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]))
- 014   + 015  
- 015  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + 016  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 016  ;;; + 017  ;;;
- 017  ;;; This file is essentially Lisp as defined in Chapter 1 (pages 1-14) of the + 018  ;;; This file is essentially Lisp as defined in Chapter 1 (pages 1-14) of the
- 018  ;;; Lisp 1.5 Programmer's Manual; that is to say, a very simple Lisp language, + 019  ;;; Lisp 1.5 Programmer's Manual; that is to say, a very simple Lisp language,
- 019  ;;; which should, I believe, be sufficient in conjunction with the functions + 020  ;;; which should, I believe, be sufficient in conjunction with the functions
- 020  ;;; provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5 + 021  ;;; provided by `beowulf.host`, be sufficient to bootstrap the full Lisp 1.5
- 021  ;;; interpreter. + 022  ;;; interpreter.
- 022  ;;; + 023  ;;;
- 023  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + 024  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 024   + 025  
- 025  (declare EVAL) + 026  (declare EVAL)
- 026   + 027  
- 027  (def oblist + 028  (def oblist
- 028    "The default environment." + 029    "The default environment."
- 029    (atom NIL)) + 030    (atom NIL))
- 030   + 031  
- 031  (def ^:dynamic *options* + 032  (def ^:dynamic *options*
- 032    "Command line options from invocation." + 033    "Command line options from invocation."
- 033    {}) + 034    {})
- 034   + 035  
- 035  (defmacro NULL + 036  (defmacro NULL
- 036    "Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`." + 037    "Returns `T` if and only if the argument `x` is bound to `NIL`; else `F`."
- 037    [x] + 038    [x]
- 038    `(if (= ~x NIL) T F)) + 039    `(if (= ~x NIL) T F))
- 039   + 040  
- 040  (defmacro ATOM + 041  (defmacro ATOM
- 041    "Returns `T` if and only is the argument `x` is bound to and atom; else `F`. + 042    "Returns `T` if and only is the argument `x` is bound to and atom; else `F`.
- 042    It is not clear to me from the documentation whether `(ATOM 7)` should return + 043    It is not clear to me from the documentation whether `(ATOM 7)` should return
- 043    `T` or `F`. I'm going to assume `T`." + 044    `T` or `F`. I'm going to assume `T`."
- 044    [x] + 045    [x]
- 045    `(if (or (symbol? ~x) (number? ~x)) T F)) + 046    `(if (or (symbol? ~x) (number? ~x)) T F))
- 046   + 047  
- 047  (defmacro ATOM? + 048  (defmacro ATOM?
- 048    "The convention of returning `F` from predicates, rather than `NIL`, is going + 049    "The convention of returning `F` from predicates, rather than `NIL`, is going
- 049    to tie me in knots. This is a variant of `ATOM` which returns `NIL` + 050    to tie me in knots. This is a variant of `ATOM` which returns `NIL`
- 050    on failure." + 051    on failure."
- 051    [x] + 052    [x]
- 052    `(if (or (symbol? ~x) (number? ~x)) T NIL)) + 053    `(if (or (symbol? ~x) (number? ~x)) T NIL))
- 053   + 054  
- 054  (defn CAR + 055  (defn CAR
- 055    "Return the item indicated by the first pointer of a pair. NIL is treated + 056    "Return the item indicated by the first pointer of a pair. NIL is treated
- 056    specially: the CAR of NIL is NIL." + 057    specially: the CAR of NIL is NIL."
- 057    [x] + 058    [x]
- 058    (cond + 059    (cond
- 059      (= x NIL) NIL + 060      (= x NIL) NIL
- 060      (instance? beowulf.cons_cell.ConsCell x) (.CAR x) + 061      (instance? beowulf.cons_cell.ConsCell x) (.CAR x)
- 061      :else + 062      :else
- 062      (throw + 063      (throw
- 063        (Exception. + 064        (Exception.
- 064          (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")"))))) + 065          (str "Cannot take CAR of `" x "` (" (.getName (.getClass x)) ")")))))
- 065   + 066  
- 066  (defn CDR + 067  (defn CDR
- 067    "Return the item indicated by the second pointer of a pair. NIL is treated + 068    "Return the item indicated by the second pointer of a pair. NIL is treated
- 068    specially: the CDR of NIL is NIL." + 069    specially: the CDR of NIL is NIL."
- 069    [x] + 070    [x]
- 070    (cond + 071    (cond
- 071      (= x NIL) NIL + 072      (= x NIL) NIL
- 072      (instance? beowulf.cons_cell.ConsCell x) (.CDR x) + 073      (instance? beowulf.cons_cell.ConsCell x) (.CDR x)
- 073      :else + 074      :else
- 074      (throw + 075      (throw
- 075        (Exception. + 076        (Exception.
- 076          (str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")"))))) + 077          (str "Cannot take CDR of `" x "` (" (.getName (.getClass x)) ")")))))
- 077   + 078  
- 078  (defn uaf + 079  (defn uaf
- 079    "Universal access function; `l` is expected to be an arbitrary list, `path` + 080    "Universal access function; `l` is expected to be an arbitrary list, `path`
- 080    a (clojure) list of the characters `a` and `d`. Intended to make declaring + 081    a (clojure) list of the characters `a` and `d`. Intended to make declaring
- 081    all those fiddly `#'c[ad]+r'` functions a bit easier" + 082    all those fiddly `#'c[ad]+r'` functions a bit easier"
- 082    [l path] + 083    [l path]
- 083    (cond + 084    (cond
- 084      (= l NIL) NIL + 085      (= l NIL) NIL
- 085      (empty? path) l + 086      (empty? path) l
- 086      :else (case (last path) + 087      :else (case (last path)
- 087              \a (uaf (CAR l) (butlast path)) + 088              \a (uaf (CAR l) (butlast path))
- 088              \d (uaf (CDR l) (butlast path))))) + 089              \d (uaf (CDR l) (butlast path)))))
- 089   + 090  
- 090  (defn CAAR [x] (uaf x (seq "aa"))) + 091  (defn CAAR [x] (uaf x (seq "aa")))
- 091  (defn CADR [x] (uaf x (seq "ad"))) + 092  (defn CADR [x] (uaf x (seq "ad")))
- 092  (defn CDDR [x] (uaf x (seq "dd"))) + 093  (defn CDDR [x] (uaf x (seq "dd")))
- 093  (defn CDAR [x] (uaf x (seq "da"))) + 094  (defn CDAR [x] (uaf x (seq "da")))
- 094   + 095  
- 095  (defn CAAAR [x] (uaf x (seq "aaa"))) + 096  (defn CAAAR [x] (uaf x (seq "aaa")))
- 096  (defn CAADR [x] (uaf x (seq "aad"))) + 097  (defn CAADR [x] (uaf x (seq "aad")))
- 097  (defn CADAR [x] (uaf x (seq "ada"))) + 098  (defn CADAR [x] (uaf x (seq "ada")))
- 098  (defn CADDR [x] (uaf x (seq "add"))) + 099  (defn CADDR [x] (uaf x (seq "add")))
- 099  (defn CDDAR [x] (uaf x (seq "dda"))) + 100  (defn CDDAR [x] (uaf x (seq "dda")))
- 100  (defn CDDDR [x] (uaf x (seq "ddd"))) + 101  (defn CDDDR [x] (uaf x (seq "ddd")))
- 101  (defn CDAAR [x] (uaf x (seq "daa"))) + 102  (defn CDAAR [x] (uaf x (seq "daa")))
- 102  (defn CDADR [x] (uaf x (seq "dad"))) + 103  (defn CDADR [x] (uaf x (seq "dad")))
- 103   + 104  
- 104  (defn CAAAAR [x] (uaf x (seq "aaaa"))) + 105  (defn CAAAAR [x] (uaf x (seq "aaaa")))
- 105  (defn CAADAR [x] (uaf x (seq "aada"))) + 106  (defn CAADAR [x] (uaf x (seq "aada")))
- 106  (defn CADAAR [x] (uaf x (seq "adaa"))) + 107  (defn CADAAR [x] (uaf x (seq "adaa")))
- 107  (defn CADDAR [x] (uaf x (seq "adda"))) + 108  (defn CADDAR [x] (uaf x (seq "adda")))
- 108  (defn CDDAAR [x] (uaf x (seq "ddaa"))) + 109  (defn CDDAAR [x] (uaf x (seq "ddaa")))
- 109  (defn CDDDAR [x] (uaf x (seq "ddda"))) + 110  (defn CDDDAR [x] (uaf x (seq "ddda")))
- 110  (defn CDAAAR [x] (uaf x (seq "daaa"))) + 111  (defn CDAAAR [x] (uaf x (seq "daaa")))
- 111  (defn CDADAR [x] (uaf x (seq "dada"))) + 112  (defn CDADAR [x] (uaf x (seq "dada")))
- 112  (defn CAAADR [x] (uaf x (seq "aaad"))) + 113  (defn CAAADR [x] (uaf x (seq "aaad")))
- 113  (defn CAADDR [x] (uaf x (seq "aadd"))) + 114  (defn CAADDR [x] (uaf x (seq "aadd")))
- 114  (defn CADADR [x] (uaf x (seq "adad"))) + 115  (defn CADADR [x] (uaf x (seq "adad")))
- 115  (defn CADDDR [x] (uaf x (seq "addd"))) + 116  (defn CADDDR [x] (uaf x (seq "addd")))
- 116  (defn CDDADR [x] (uaf x (seq "ddad"))) + 117  (defn CDDADR [x] (uaf x (seq "ddad")))
- 117  (defn CDDDDR [x] (uaf x (seq "dddd"))) + 118  (defn CDDDDR [x] (uaf x (seq "dddd")))
- 118  (defn CDAADR [x] (uaf x (seq "daad"))) + 119  (defn CDAADR [x] (uaf x (seq "daad")))
- 119  (defn CDADDR [x] (uaf x (seq "dadd"))) + 120  (defn CDADDR [x] (uaf x (seq "dadd")))
- 120   + 121  
- 121  (defn EQ + 122  (defn EQ
- 122    "Returns `T` if and only if both `x` and `y` are bound to the same atom, + 123    "Returns `T` if and only if both `x` and `y` are bound to the same atom,
- 123    else `F`." + 124    else `F`."
- 124    [x y] + 125    [x y]
- 125    (if (and (= (ATOM x) T) (= x y)) T F)) + 126    (if (and (= (ATOM x) T) (= x y)) T F))
- 126   + 127  
- 127  (defn EQUAL + 128  (defn EQUAL
- 128    "This is a predicate that is true if its two arguments are identical + 129    "This is a predicate that is true if its two arguments are identical
- 129    S-expressions, and false if they are different. (The elementary predicate + 130    S-expressions, and false if they are different. (The elementary predicate
- 130    `EQ` is defined only for atomic arguments.) The definition of `EQUAL` is + 131    `EQ` is defined only for atomic arguments.) The definition of `EQUAL` is
- 131    an example of a conditional expression inside a conditional expression. + 132    an example of a conditional expression inside a conditional expression.
- 132   + 133  
- 133    NOTE: returns `F` on failure, not `NIL`" + 134    NOTE: returns `F` on failure, not `NIL`"
- 134    [x y] + 135    [x y]
- 135    (cond + 136    (cond
- 136      (= (ATOM x) T) (EQ x y) + 137      (= (ATOM x) T) (EQ x y)
- 137      (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y)) + 138      (= (EQUAL (CAR x) (CAR y)) T) (EQUAL (CDR x) (CDR y))
- 138      :else F)) + 139      :else F))
- 139   + 140  
- 140  (defn SUBST + 141  (defn SUBST
- 141    "This function gives the result of substituting the S-expression `x` for + 142    "This function gives the result of substituting the S-expression `x` for
- 142    all occurrences of the atomic symbol `y` in the S-expression `z`." + 143    all occurrences of the atomic symbol `y` in the S-expression `z`."
- 143    [x y z] + 144    [x y z]
- 144    (cond + 145    (cond
- 145      (= (EQUAL y z) T) x + 146      (= (EQUAL y z) T) x
- 146      (= (ATOM? z) T) z ;; NIL is a symbol + 147      (= (ATOM? z) T) z ;; NIL is a symbol
- 147      :else + 148      :else
- 148      (make-cons-cell (SUBST x y (CAR z)) (SUBST x y (CDR z))))) + 149      (make-cons-cell (SUBST x y (CAR z)) (SUBST x y (CDR z)))))
- 149   + 150  
- 150  (defn APPEND + 151  (defn APPEND
- 151    "Append the the elements of `y` to the elements of `x`. + 152    "Append the the elements of `y` to the elements of `x`.
- 152   + 153  
- 153    All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + 154    All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
- 154    See page 11 of the Lisp 1.5 Programmers Manual." + 155    See page 11 of the Lisp 1.5 Programmers Manual."
- 155    [x y] + 156    [x y]
- 156    (cond + 157    (cond
- 157      (= x NIL) y + 158      (= x NIL) y
- 158      :else + 159      :else
- 159      (make-cons-cell (CAR x) (APPEND (CDR x) y)))) -
- - 160   + 160      (make-cons-cell (CAR x) (APPEND (CDR x) y))))
161  
+ + 162   +
- 162  (defn MEMBER + 163  (defn MEMBER
- 163    "This predicate is true if the S-expression `x` occurs among the elements + 164    "This predicate is true if the S-expression `x` occurs among the elements
- 164    of the list `y`. + 165    of the list `y`.
- 165   + 166  
- 166    All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. + 167    All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects.
- 167    See page 11 of the Lisp 1.5 Programmers Manual." + 168    See page 11 of the Lisp 1.5 Programmers Manual."
- 168    [x y] + 169    [x y]
- 169    (cond + 170    (cond
- 170      (= y NIL) F ;; NOTE: returns F on falsity, not NIL + 171      (= y NIL) F ;; NOTE: returns F on falsity, not NIL
- 171      (= (EQUAL x (CAR y)) T) T + 172      (= (EQUAL x (CAR y)) T) T
- 172      :else (MEMBER x (CDR y)))) + 173      :else (MEMBER x (CDR y))))
- 173   + 174  
- 174  (defn PAIRLIS + 175  (defn PAIRLIS
- 175    "This function gives the list of pairs of corresponding elements of the + 176    "This function gives the list of pairs of corresponding elements of the
- 176    lists `x` and `y`, and APPENDs this to the list `a`. The resultant list + 177    lists `x` and `y`, and APPENDs this to the list `a`. The resultant list
- 177    of pairs, which is like a table with two columns, is called an + 178    of pairs, which is like a table with two columns, is called an
- 178    association list. + 179    association list.
- 179   + 180  
- 180    Eessentially, it builds the environment on the stack, implementing shallow + 181    Eessentially, it builds the environment on the stack, implementing shallow
- 181    binding. + 182    binding.
- 182   + 183  
- 183    All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + 184    All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
- 184    See page 12 of the Lisp 1.5 Programmers Manual." + 185    See page 12 of the Lisp 1.5 Programmers Manual."
- 185    [x y a] + 186    [x y a]
- 186    (cond + 187    (cond
- 187      ;; the original tests only x; testing y as well will be a little more + 188      ;; the original tests only x; testing y as well will be a little more
- 188      ;; robust if `x` and `y` are not the same length. + 189      ;; robust if `x` and `y` are not the same length.
- 189      (or (= NIL x) (= NIL y)) a + 190      (or (= NIL x) (= NIL y)) a
- 190      :else (make-cons-cell + 191      :else (make-cons-cell
- 191              (make-cons-cell (CAR x) (CAR y)) + 192              (make-cons-cell (CAR x) (CAR y))
- 192              (PAIRLIS (CDR x) (CDR y) a)))) + 193              (PAIRLIS (CDR x) (CDR y) a))))
- 193   + 194  
- 194  (defn ASSOC + 195  (defn ASSOC
- 195    "If a is an association list such as the one formed by PAIRLIS in the above + 196    "If a is an association list such as the one formed by PAIRLIS in the above
- 196    example, then assoc will produce the first pair whose first term is x. Thus + 197    example, then assoc will produce the first pair whose first term is x. Thus
- 197    it is a table searching function. + 198    it is a table searching function.
- 198   + 199  
- 199    All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + 200    All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
- 200    See page 12 of the Lisp 1.5 Programmers Manual." + 201    See page 12 of the Lisp 1.5 Programmers Manual."
- 201    [x a] + 202    [x a]
- 202    (cond + 203    (cond
- 203      (= NIL a) NIL ;; this clause is not present in the original but is added for + 204      (= NIL a) NIL ;; this clause is not present in the original but is added for
- 204      ;; robustness. + 205      ;; robustness.
- 205      (= (EQUAL (CAAR a) x) T) (CAR a) + 206      (= (EQUAL (CAAR a) x) T) (CAR a)
- 206      :else + 207      :else
- 207      (ASSOC x (CDR a)))) + 208      (ASSOC x (CDR a))))
- 208   + 209  
- 209  (defn- SUB2 + 210  (defn- SUB2
- 210    "Internal to `SUBLIS`, q.v., which SUBSTitutes into a list from a store. + 211    "Internal to `SUBLIS`, q.v., which SUBSTitutes into a list from a store.
- 211    ? I think this is doing variable binding in the stack frame?" + 212    ? I think this is doing variable binding in the stack frame?"
- 212    [a z] + 213    [a z]
- 213    (cond + 214    (cond
- 214      (= NIL a) z + 215      (= NIL a) z
- 215      (= (CAAR a) z) (CDAR a) ;; TODO: this looks definitely wrong + 216      (= (CAAR a) z) (CDAR a) ;; TODO: this looks definitely wrong
- 216      :else + 217      :else
- 217      (SUB2 (CDR a) z))) + 218      (SUB2 (CDR a) z)))
- 218   + 219  
- 219  (defn SUBLIS + 220  (defn SUBLIS
- 220    "Here `a` is assumed to be an association list of the form + 221    "Here `a` is assumed to be an association list of the form
- 221    `((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any + 222    `((ul . vl)...(un . vn))`, where the `u`s are atomic, and `y` is any
- 222    S-expression. What `SUBLIS` does, is to treat the `u`s as variables when + 223    S-expression. What `SUBLIS` does, is to treat the `u`s as variables when
- 223    they occur in `y`, and to SUBSTitute the corresponding `v`s from the pair + 224    they occur in `y`, and to SUBSTitute the corresponding `v`s from the pair
- 224    list. + 225    list.
- 225   + 226  
- 226    My interpretation is that this is variable binding in the stack frame. + 227    My interpretation is that this is variable binding in the stack frame.
- 227   + 228  
- 228    All args are assumed to be `beowulf.cons-cell/ConsCell` objects. + 229    All args are assumed to be `beowulf.cons-cell/ConsCell` objects.
- 229    See page 12 of the Lisp 1.5 Programmers Manual." + 230    See page 12 of the Lisp 1.5 Programmers Manual."
- 230    [a y] + 231    [a y]
- 231    (cond + 232    (cond
- 232      (= (ATOM? y) T) (SUB2 a y) + 233      (= (ATOM? y) T) (SUB2 a y)
- 233      :else + 234      :else
- 234      (make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y))))) + 235      (make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y)))))
- 235   + 236  
- 236  (defn APPLY + 237  (defn interop-interpret-q-name
- 237    "For bootstrapping, at least, a version of APPLY written in Clojure. + 238    "For interoperation with Clojure, it will often be necessary to pass
- 238    All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. + 239    qualified names that are not representable in Lisp 1.5. This function
- 239    See page 13 of the Lisp 1.5 Programmers Manual." + 240    takes a sequence in the form `(PART PART PART... NAME)` and returns
- 240    [function args environment] -
- - 241    (cond -
- - 242      (= -
- - 243        (ATOM? function) -
- - 244        T)(cond + 241    a symbol in the form `PART.PART.PART/NAME`. This symbol will then be
- 245             ;; TODO: doesn't check whether `function` is bound in the environment; + 242    tried in both that form and lower-cased. Names with hyphens or
- 246             ;; we'll need that before we can bootstrap. -
- - 247             (= function 'CAR) (CAAR args) -
- - 248             (= function 'CDR) (CDAR args) -
- - 249             (= function 'CONS) (make-cons-cell (CAR args) (CADR args)) -
- - 250             (= function 'ATOM) (if (ATOM? (CAR args)) T NIL) -
- - 251             (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL) + 243    underscores cannot be represented with this scheme."
- 252             :else + 244    [l] +
+ + 245    (if +
+ + 246      (seq? l)
- 253             (APPLY + 247      (symbol +
+ + 248        (s/reverse
- 254               (EVAL function environment) + 249          (s/replace-first
- - 255               args -
- - 256               environment)) -
- - 257      (= (first function) 'LAMBDA) (EVAL -
- - 258                                     (CADDR function) + + 250            (s/reverse
- 259                                     (PAIRLIS (CADR function) args environment)) + 251              (s/join "." (map str l)))
- - 260      (= (first function) 'LABEL) (APPLY + + 252            "."
- - 261                                    (CADDR function) + + 253            "/")))
- 262                                    args + 254      l))
- - 263                                    (make-cons-cell + + 255  
- - 264                                      (make-cons-cell + + 256  (deftrace INTEROP
- - 265                                        (CADR function) + + 257    "Clojure (or other host environment) interoperation API. `fn-symbol` is expected
- - 266                                        (CADDR function)) + + 258    to be either
- - 267                                      environment)))) + + 259   +
+ + 260    1. a symbol bound in the host environment to a function; or +
+ + 261    2. a sequence (list) of symbols forming a qualified path name bound to a +
+ + 262       function. +
+ + 263   +
+ + 264    Lower case characters cannot normally be represented in Lisp 1.5, so both the +
+ + 265    upper case and lower case variants of `fn-symbol` will be tried. If the +
+ + 266    function you're looking for has a mixed case name, that is not currently +
+ + 267    accessible.
268  
- - 269  (defn- EVCON + + 269    `args` is expected to be a Lisp 1.5 list of arguments to be passed to that
- 270    "Inner guts of primitive COND. All args are assumed to be + 270    function. Return value must be something acceptable to Lisp 1.5, so either
- 271    `beowulf.cons-cell/ConsCell` objects. + 271    a symbol, a number, or a Lisp 1.5 list. +
+ + 272  
- 272    See page 13 of the Lisp 1.5 Programmers Manual." + 273    If `fn-symbol` is not found (even when cast to lower case), or is not a function,
- 273    [clauses env] + 274    or the value returned cannot be represented in Lisp 1.5, an exception is thrown +
+ + 275    with `:cause` bound to `:interop` and `:detail` set to a value representing the +
+ + 276    actual problem." +
+ + 277    [fn-symbol args]
- 274    (if + 278    (let
- - 275      (not= (EVAL (CAAR clauses) env) NIL) -
- - 276      (EVAL (CADAR clauses) env) -
- - 277      (EVCON (CDR clauses) env))) -
- - 278   -
- - 279  (defn- EVLIS -
- - 280    "Map `EVAL` across this list of `args` in the context of this -
- - 281    `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects. -
- - 282    See page 13 of the Lisp 1.5 Programmers Manual." -
- - 283    [args env] -
- - 284    (cond -
- - 285      (= NIL args) NIL -
- - 286      :else -
- - 287      (make-cons-cell -
- - 288        (EVAL (CAR args) env) -
- - 289        (EVLIS (CDR args) env)))) -
- - 290   -
- - 291  (deftrace traced-eval -
- - 292    "Essentially, identical to EVAL except traced." -
- - 293    [expr env] -
- - 294    (cond -
- - 295      (= -
- - 296        (ATOM? expr) T) -
- - 297      (CDR (ASSOC expr env)) -
- - 298      (= -
- - 299        (ATOM? (CAR expr)) -
- - 300        T)(cond -
- - 301             (= (CAR expr) 'QUOTE) (CADR expr) -
- - 302             (= (CAR expr) 'COND) (EVCON (CDR expr) env) -
- - 303             :else (APPLY -
- - 304                     (CAR expr) -
- - 305                     (EVLIS (CDR expr) env) -
- - 306                     env)) -
- - 307      :else (APPLY + + 279      [q-name (if
- 308              (CAR expr) + 280                (seq? fn-symbol)
- - 309              (EVLIS (CDR expr) env) + + 281                (interop-interpret-q-name fn-symbol)
- 310              env))) + 282                fn-symbol) +
+ + 283       l-name (symbol (s/lower-case q-name)) +
+ + 284       f (cond +
+ + 285              (try +
+ + 286                (fn? (eval l-name)) +
+ + 287                (catch java.lang.ClassNotFoundException e nil)) (eval l-name) +
+ + 288              (try +
+ + 289                (fn? (eval q-name)) +
+ + 290                (catch java.lang.ClassNotFoundException e nil)) (eval q-name) +
+ + 291               :else (throw +
+ + 292                       (ex-info +
+ + 293                         (str "INTEROP: unknown function `" fn-symbol "`") +
+ + 294                         {:cause :interop +
+ + 295                          :detail :not-found +
+ + 296                           :name fn-symbol +
+ + 297                           :also-tried l-name}))) +
+ + 298        result (eval (cons f args))] +
+ + 299      (cond +
+ + 300        (instance? beowulf.cons_cell.ConsCell result) result +
+ + 301        (seq? result) (make-beowulf-list result) +
+ + 302        (symbol? result) result +
+ + 303        (string? result) (symbol result) +
+ + 304        (number? result) result +
+ + 305        :else (throw +
+ + 306                (ex-info +
+ + 307                  (str "INTEROP: Cannot return `" result "` to Lisp 1.5.") +
+ + 308                  {:cause :interop +
+ + 309                   :detail :not-representable +
+ + 310                   :result result})))))
311  
- 312  (defn EVAL + 312  (defn APPLY
- 313    "For bootstrapping, at least, a version of EVAL written in Clojure. + 313    "For bootstrapping, at least, a version of APPLY written in Clojure.
314    All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. @@ -950,73 +950,301 @@ 315    See page 13 of the Lisp 1.5 Programmers Manual."
- 316    [expr env] + 316    [function args environment]
- + 317    (cond
- - 318      (true? (:trace *options*)) -
- - 319      (traced-eval expr env) -
- 320      (= + 318      (=
- - 321        (ATOM? expr) T) + + 319        (ATOM? function)
- - 322      (CDR (ASSOC expr env)) + + 320        T)(cond
- - 323      (= + + 321             ;; TODO: doesn't check whether `function` is bound in the environment;
- - 324        (ATOM? (CAR expr)) + + 322             ;; we'll need that before we can bootstrap.
- - 325        T)(cond + + 323             (= function 'CAR) (CAAR args)
- - 326             (= (CAR expr) 'QUOTE) (CADR expr) + + 324             (= function 'CDR) (CDAR args)
- - 327             (= (CAR expr) 'COND) (EVCON (CDR expr) env) + + 325             (= function 'CONS) (make-cons-cell (CAR args) (CADR args))
- - 328             :else (APPLY + + 326             (= function 'ATOM) (if (ATOM? (CAR args)) T NIL)
- - 329                     (CAR expr) + + 327             (= function 'EQ) (if (= (CAR args) (CADR args)) T NIL)
- - 330                     (EVLIS (CDR expr) env) -
- - 331                     env)) + + 328             :else
- 332      :else (APPLY + 329             (APPLY
- - 333              (CAR expr) -
- - 334              (EVLIS (CDR expr) env) + + 330               (EVAL function environment)
- 335              env))) + 331               args +
+ + 332               environment)) +
+ + 333      (= (first function) 'LAMBDA) (EVAL +
+ + 334                                     (CADDR function) +
+ + 335                                     (PAIRLIS (CADR function) args environment)) +
+ + 336      (= (first function) 'LABEL) (APPLY +
+ + 337                                    (CADDR function) +
+ + 338                                    args +
+ + 339                                    (make-cons-cell +
+ + 340                                      (make-cons-cell +
+ + 341                                        (CADR function) +
+ + 342                                        (CADDR function)) +
+ + 343                                      environment))))
- 336   + 344   +
+ + 345  (defn- EVCON +
+ + 346    "Inner guts of primitive COND. All args are assumed to be +
+ + 347    `beowulf.cons-cell/ConsCell` objects. +
+ + 348    See page 13 of the Lisp 1.5 Programmers Manual." +
+ + 349    [clauses env] +
+ + 350    (if +
+ + 351      (not= (EVAL (CAAR clauses) env) NIL) +
+ + 352      (EVAL (CADAR clauses) env) +
+ + 353      (EVCON (CDR clauses) env)))
- 337   + 354   +
+ + 355  (defn- EVLIS +
+ + 356    "Map `EVAL` across this list of `args` in the context of this +
+ + 357    `env`ironment.All args are assumed to be `beowulf.cons-cell/ConsCell` objects. +
+ + 358    See page 13 of the Lisp 1.5 Programmers Manual." +
+ + 359    [args env] +
+ + 360    (cond +
+ + 361      (= NIL args) NIL +
+ + 362      :else +
+ + 363      (make-cons-cell +
+ + 364        (EVAL (CAR args) env) +
+ + 365        (EVLIS (CDR args) env))))
- 338   + 366   +
+ + 367  (deftrace traced-eval +
+ + 368    "Essentially, identical to EVAL except traced." +
+ + 369    [expr env] +
+ + 370    (cond +
+ + 371      (= +
+ + 372        (ATOM? expr) T) +
+ + 373      (CDR (ASSOC expr env)) +
+ + 374      (= +
+ + 375        (ATOM? (CAR expr)) +
+ + 376        T)(cond +
+ + 377             (= (CAR expr) 'QUOTE) (CADR expr) +
+ + 378             (= (CAR expr) 'COND) (EVCON (CDR expr) env) +
+ + 379             :else (APPLY +
+ + 380                     (CAR expr) +
+ + 381                     (EVLIS (CDR expr) env) +
+ + 382                     env)) +
+ + 383      :else (APPLY +
+ + 384              (CAR expr) +
+ + 385              (EVLIS (CDR expr) env) +
+ + 386              env))) +
+ + 387   +
+ + 388  (defn EVAL +
+ + 389    "For bootstrapping, at least, a version of EVAL written in Clojure. +
+ + 390    All args are assumed to be symbols or `beowulf.cons-cell/ConsCell` objects. +
+ + 391    See page 13 of the Lisp 1.5 Programmers Manual." +
+ + 392    [expr env] +
+ + 393    (cond +
+ + 394      (true? (:trace *options*)) +
+ + 395      (traced-eval expr env) +
+ + 396      (= +
+ + 397        (ATOM? expr) T) +
+ + 398      (CDR (ASSOC expr env)) +
+ + 399      (= +
+ + 400        (ATOM? (CAR expr)) +
+ + 401        T)(cond +
+ + 402             (= (CAR expr) 'QUOTE) (CADR expr) +
+ + 403             (= (CAR expr) 'COND) (EVCON (CDR expr) env) +
+ + 404             :else (APPLY +
+ + 405                     (CAR expr) +
+ + 406                     (EVLIS (CDR expr) env) +
+ + 407                     env)) +
+ + 408      :else (APPLY +
+ + 409              (CAR expr) +
+ + 410              (EVLIS (CDR expr) env) +
+ + 411              env))) +
+ + 412   +
+ + 413   +
+ + 414  
diff --git a/docs/cloverage/index.html b/docs/cloverage/index.html index b2e4ae4..b064548 100644 --- a/docs/cloverage/index.html +++ b/docs/cloverage/index.html @@ -16,20 +16,20 @@ beowulf.bootstrap
752
363
-67.44 % + style="width:60.47808764940239%; + float:left;"> 759
496
+60.48 %
103
41
32
-81.82 % -33840176 + style="width:47.92626728110599%; + float:left;"> 104
42
71
+67.28 % +41446217 beowulf.cons-cell
Totals: -72.95 % +68.97 % -79.52 % +72.89 % diff --git a/project.clj b/project.clj index 1e3cecb..c2bd739 100644 --- a/project.clj +++ b/project.clj @@ -1,4 +1,4 @@ -(defproject beowulf "0.2.1-SNAPSHOT" +(defproject beowulf "0.2.1" :cloverage {:output "docs/cloverage"} :codox {:metadata {:doc "**TODO**: write docs" :doc/format :markdown} @@ -13,7 +13,9 @@ [org.clojure/tools.trace "0.7.10"] [environ "1.1.0"] [instaparse "1.4.10"]] + :java-source-paths ["src/java"] :main ^:skip-aot beowulf.core + :min-lein-version "2.0.0" :plugins [[lein-cloverage "1.1.1"] [lein-codox "0.10.7"] [lein-environ "1.1.0"]] @@ -28,7 +30,7 @@ ["uberjar"] ["change" "version" "leiningen.release/bump-version"] ["vcs" "commit"]] - + :source-paths ["src/clojure"] :target-path "target/%s" - :url "https://github.com/simon-brooke/the-great-game" + :url "https://github.com/simon-brooke/beowulf" ) diff --git a/src/beowulf/cons_cell.clj b/src/beowulf/cons_cell.clj deleted file mode 100644 index 3fd104b..0000000 --- a/src/beowulf/cons_cell.clj +++ /dev/null @@ -1,156 +0,0 @@ -(ns beowulf.cons-cell - "The fundamental cons cell on which all Lisp structures are built. - Lisp 1.5 lists do not necessarily have a sequence as their CDR, so - cannot be implemented on top of Clojure lists.") - -(def NIL - "The canonical empty list symbol." - (symbol "NIL")) - -(def T - "The canonical true value." - (symbol "T")) ;; true. - -(def F - "The canonical false value - different from `NIL`, which is not canonically - false in Lisp 1.5." - (symbol "F")) ;; false as distinct from nil - -(deftype ConsCell [CAR CDR] - clojure.lang.ISeq - (cons [this x] (ConsCell. x this)) - (first [this] (.CAR this)) - ;; next and more must return ISeq: - ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java - (more [this] (if - (seq? (.CDR this)) - (.CDR this) - clojure.lang.PersistentList/EMPTY)) - (next [this] (if - (seq? (.CDR this)) - (.CDR this) - nil ;; next returns nil when empty - )) - - clojure.lang.Seqable - (seq [this] this) - - ;; for some reason this marker protocol is needed otherwise compiler complains - ;; that `nth not supported on ConsCell` - clojure.lang.Sequential - - clojure.lang.IPersistentCollection - (count [this] (if - (coll? (.CDR this)) - (inc (.count (.CDR this))) - 1)) - (empty [this] false) ;; a cons cell is by definition not empty. - (equiv [this other] (if - (seq? other) - (and - (if - (and - (seq? (first this)) - (seq? (first other))) - (.equiv (first this) (first other)) - (= (first this) (first other))) - (if - (and - (seq? (rest this)) - (seq? (rest other))) - (.equiv (rest this) (rest other)) - (= (rest this) (rest other)))) - false))) - -(defn- to-string - "Printing ConsCells gave me a *lot* of trouble. This is an internal function - used by the print-method override (below) in order that the standard Clojure - `print` and `str` functions will print ConsCells correctly. The argument - `cell` must, obviously, be an instance of `ConsCell`." - [cell] - (loop [c cell - n 0 - s "("] - (if - (instance? beowulf.cons_cell.ConsCell c) - (let [car (.CAR c) - cdr (.CDR c) - cons? (instance? beowulf.cons_cell.ConsCell cdr) - ss (str - s - (to-string car) - (cond - cons? - " " - (or (nil? cdr) (= cdr 'NIL)) - ")" - :else - (str " . " (to-string cdr) ")")))] - (if - cons? - (recur cdr (inc n) ss) - ss)) - (str c)))) - -(defn pretty-print - "This isn't the world's best pretty printer but it sort of works." - ([^beowulf.cons_cell.ConsCell cell] - (println (pretty-print cell 80 0))) - ([^beowulf.cons_cell.ConsCell cell width level] - (loop [c cell - n (inc level) - s "("] - (if - (instance? beowulf.cons_cell.ConsCell c) - (let [car (.CAR c) - cdr (.CDR c) - cons? (instance? beowulf.cons_cell.ConsCell cdr) - print-width (count (print-str c)) - indent (apply str (repeat n " ")) - ss (str - s - (pretty-print car width n) - (cond - cons? - (if - (< (+ (count indent) print-width) width) - " " - (str "\n" indent)) - (or (nil? cdr) (= cdr 'NIL)) - ")" - :else - (str " . " (pretty-print cdr width n) ")")))] - (if - cons? - (recur cdr n ss) - ss)) - (str c))))) - - - -(defmethod clojure.core/print-method - ;;; I have not worked out how to document defmethod without blowing up the world. - beowulf.cons_cell.ConsCell - [this writer] - (.write writer (to-string this))) - - -(defmacro make-cons-cell - "Construct a new instance of cons cell with this `car` and `cdr`." - [car cdr] - `(ConsCell. ~car ~cdr)) - -(defn make-beowulf-list - "Construct a linked list of cons cells with the same content as the - sequence `x`." - [x] - (cond - (empty? x) NIL - (coll? x) (ConsCell. - (if - (seq? (first x)) - (make-beowulf-list (first x)) - (first x)) - (make-beowulf-list (rest x))) - :else - NIL)) diff --git a/src/beowulf/host.clj b/src/beowulf/host.clj deleted file mode 100644 index fcd71fd..0000000 --- a/src/beowulf/host.clj +++ /dev/null @@ -1,5 +0,0 @@ -(ns beowulf.host - "provides Lisp 1.5 functions which can't be (or can't efficiently - be) implemented in Lisp 1.5, which therefore need to be implemented in the - host language, in this case Clojure.") - diff --git a/src/beowulf/bootstrap.clj b/src/clojure/beowulf/bootstrap.clj similarity index 77% rename from src/beowulf/bootstrap.clj rename to src/clojure/beowulf/bootstrap.clj index 4e72869..8ca3d3a 100644 --- a/src/beowulf/bootstrap.clj +++ b/src/clojure/beowulf/bootstrap.clj @@ -7,10 +7,12 @@ The convention is adopted that functions in this file with names in ALLUPPERCASE are Lisp 1.5 functions (although written in Clojure) and that - therefore all arguments must be numbers, symbols or `beowulf.cons_cell.ConsCell` + therefore all arguments must be numbers, symbols or `beowulf.substrate.ConsCell` objects." - (:require [clojure.tools.trace :refer :all] - [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]])) + (:require [clojure.string :as s] + [clojure.tools.trace :refer :all] + [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]) + (:import (beowulf.substrate ConsCell))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -57,7 +59,7 @@ [x] (cond (= x NIL) NIL - (instance? beowulf.cons_cell.ConsCell x) (.CAR x) + (instance? ConsCell x) (.getCar x) :else (throw (Exception. @@ -69,7 +71,7 @@ [x] (cond (= x NIL) NIL - (instance? beowulf.cons_cell.ConsCell x) (.CDR x) + (instance? ConsCell x) (.getCdr x) :else (throw (Exception. @@ -233,6 +235,81 @@ :else (make-cons-cell (SUBLIS a (CAR y)) (SUBLIS a (CDR y))))) +(defn interop-interpret-q-name + "For interoperation with Clojure, it will often be necessary to pass + qualified names that are not representable in Lisp 1.5. This function + takes a sequence in the form `(PART PART PART... NAME)` and returns + a symbol in the form `PART.PART.PART/NAME`. This symbol will then be + tried in both that form and lower-cased. Names with hyphens or + underscores cannot be represented with this scheme." + [l] + (if + (seq? l) + (symbol + (s/reverse + (s/replace-first + (s/reverse + (s/join "." (map str l))) + "." + "/"))) + l)) + +(deftrace INTEROP + "Clojure (or other host environment) interoperation API. `fn-symbol` is expected + to be either + + 1. a symbol bound in the host environment to a function; or + 2. a sequence (list) of symbols forming a qualified path name bound to a + function. + + Lower case characters cannot normally be represented in Lisp 1.5, so both the + upper case and lower case variants of `fn-symbol` will be tried. If the + function you're looking for has a mixed case name, that is not currently + accessible. + + `args` is expected to be a Lisp 1.5 list of arguments to be passed to that + function. Return value must be something acceptable to Lisp 1.5, so either + a symbol, a number, or a Lisp 1.5 list. + + If `fn-symbol` is not found (even when cast to lower case), or is not a function, + or the value returned cannot be represented in Lisp 1.5, an exception is thrown + with `:cause` bound to `:interop` and `:detail` set to a value representing the + actual problem." + [fn-symbol args] + (let + [q-name (if + (seq? fn-symbol) + (interop-interpret-q-name fn-symbol) + fn-symbol) + l-name (symbol (s/lower-case q-name)) + f (cond + (try + (fn? (eval l-name)) + (catch java.lang.ClassNotFoundException e nil)) (eval l-name) + (try + (fn? (eval q-name)) + (catch java.lang.ClassNotFoundException e nil)) (eval q-name) + :else (throw + (ex-info + (str "INTEROP: unknown function `" fn-symbol "`") + {:cause :interop + :detail :not-found + :name fn-symbol + :also-tried l-name}))) + result (eval (cons f args))] + (cond + (instance? ConsCell result) result + (seq? result) (make-beowulf-list result) + (symbol? result) result + (string? result) (symbol result) + (number? result) result + :else (throw + (ex-info + (str "INTEROP: Cannot return `" result "` to Lisp 1.5.") + {:cause :interop + :detail :not-representable + :result result}))))) + (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. diff --git a/src/clojure/beowulf/cons_cell.clj b/src/clojure/beowulf/cons_cell.clj new file mode 100644 index 0000000..5c04188 --- /dev/null +++ b/src/clojure/beowulf/cons_cell.clj @@ -0,0 +1,181 @@ +(ns beowulf.cons-cell + "The fundamental cons cell on which all Lisp structures are built. + Lisp 1.5 lists do not necessarily have a sequence as their CDR, so + cannot be implemented on top of Clojure lists." + (:import (beowulf.substrate ConsCell) + (java.io Writer))) + +(def NIL + "The canonical empty list symbol." + 'NIL) + +(def T + "The canonical true value." + 'T) ;; true. + +(def F + "The canonical false value - different from `NIL`, which is not canonically + false in Lisp 1.5." + 'F) ;; false as distinct from nil + +;; (deftype ConsCell [^:unsynchronized-mutable car ^:unsynchronized-mutable cdr] +;; ;; Note that, because the CAR and CDR fields are unsynchronised mutable - i.e. +;; ;; plain old Java instance variables which can be written as well as read - +;; ;; ConsCells are NOT thread safe. This does not matter, since Lisp 1.5 is +;; ;; single threaded. + +;; (CAR [this] (.car this)) +;; (CDR [this] (.cdr this)) +;; (RPLACA +;; [this value] +;; (if +;; (or +;; (instance? beowulf.substrate.ConsCell value) +;; (number? value) +;; (symbol? value) +;; (= value NIL)) +;; (do +;; (set! (. cell CAR) value) +;; cell) +;; (throw (ex-info +;; (str "Invalid value in RPLACA: `" value "` (" (type value) ")") +;; {:cause :bad-value +;; :detail :rplaca})))) + +;; clojure.lang.ISeq +;; (cons [this x] (ConsCell. x this)) +;; (first [this] (.CAR this)) +;; ;; next and more must return ISeq: +;; ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java +;; (more [this] (if +;; (seq? (.CDR this)) +;; (.CDR this) +;; clojure.lang.PersistentList/EMPTY)) +;; (next [this] (if +;; (seq? (.CDR this)) +;; (.CDR this) +;; nil ;; next returns nil when empty +;; )) + +;; clojure.lang.Seqable +;; (seq [this] this) + +;; ;; for some reason this marker protocol is needed otherwise compiler complains +;; ;; that `nth not supported on ConsCell` +;; clojure.lang.Sequential + +;; clojure.lang.IPersistentCollection +;; (count [this] (if +;; (coll? (.CDR this)) +;; (inc (.count (.CDR this))) +;; 1)) +;; (empty [this] false) ;; a cons cell is by definition not empty. +;; (equiv [this other] (if +;; (seq? other) +;; (and +;; (if +;; (and +;; (seq? (first this)) +;; (seq? (first other))) +;; (.equiv (first this) (first other)) +;; (= (first this) (first other))) +;; (if +;; (and +;; (seq? (rest this)) +;; (seq? (rest other))) +;; (.equiv (rest this) (rest other)) +;; (= (rest this) (rest other)))) +;; false))) + +;(defn- to-string +; "Printing ConsCells gave me a *lot* of trouble. This is an internal function +; used by the print-method override (below) in order that the standard Clojure +; `print` and `str` functions will print ConsCells correctly. The argument +; `cell` must, obviously, be an instance of `ConsCell`." +; [cell] +; (loop [c cell +; n 0 +; s "("] +; (if +; (instance? ConsCell c) +; (let [car (.getCar c) +; cdr (.getCdr c) +; cons? (instance? ConsCell cdr) +; ss (str +; s +; (to-string car) +; (cond +; cons? +; " " +; (or (nil? cdr) (= cdr 'NIL)) +; ")" +; :else +; (str " . " (to-string cdr) ")")))] +; (if +; cons? +; (recur cdr (inc n) ss) +; ss)) +; (str c)))) + +(defn pretty-print + "This isn't the world's best pretty printer but it sort of works." + ([^ConsCell cell] + (println (pretty-print cell 80 0))) + ([^ConsCell cell width level] + (loop [c cell + n (inc level) + s "("] + (if + (instance? ConsCell c) + (let [car (.getCar c) + cdr (.getCdr c) + cons? (instance? ConsCell cdr) + print-width (count (print-str c)) + indent (apply str (repeat n " ")) + ss (str + s + (pretty-print car width n) + (cond + cons? + (if + (< (+ (count indent) print-width) width) + " " + (str "\n" indent)) + (or (nil? cdr) (= cdr 'NIL)) + ")" + :else + (str " . " (pretty-print cdr width n) ")")))] + (if + cons? + (recur cdr n ss) + ss)) + (str c))))) + + + +(defmethod clojure.core/print-method + ;;; I have not worked out how to document defmethod without blowing up the world. + ConsCell + [this ^Writer writer] + (.write writer (.toString this))) + + +(defmacro make-cons-cell + "Construct a new instance of cons cell with this `car` and `cdr`." + [car cdr] + `(ConsCell. ~car ~cdr)) + +(defn make-beowulf-list + "Construct a linked list of cons cells with the same content as the + sequence `x`." + [x] + (cond + (empty? x) NIL + (coll? x) (ConsCell. + (if + (coll? (first x)) + (make-beowulf-list (first x)) + (first x)) + (make-beowulf-list (rest x))) + :else + NIL)) diff --git a/src/beowulf/core.clj b/src/clojure/beowulf/core.clj similarity index 100% rename from src/beowulf/core.clj rename to src/clojure/beowulf/core.clj diff --git a/src/clojure/beowulf/host.clj b/src/clojure/beowulf/host.clj new file mode 100644 index 0000000..b716ec6 --- /dev/null +++ b/src/clojure/beowulf/host.clj @@ -0,0 +1,91 @@ +(ns beowulf.host + "provides Lisp 1.5 functions which can't be (or can't efficiently + be) implemented in Lisp 1.5, which therefore need to be implemented in the + host language, in this case Clojure." + (:require [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]]) + (:import (beowulf.substrate ConsCell))) + +;; these are CANDIDATES to be host-implemented. only a subset of them MUST be. +;; those which can be implemented in Lisp should be, since that aids +;; portability. + +;; RPLACA + +(defn RPLACA + "Replace the CAR pointer of this `cell` with this `value`. Dangerous, should + really not exist, but does in Lisp 1.5 (and was important for some + performance hacks in early Lisps)" + [^ConsCell cell value] + (if + (instance? ConsCell cell) + (if + (or + (instance? ConsCell value) + (number? value) + (symbol? value) + (= value NIL)) + (do + (.setCar cell value) + cell) + (throw (ex-info + (str "Invalid value in RPLACA: `" value "` (" (type value) ")") + {:cause :bad-value + :detail :rplaca}))) + (throw (ex-info + (str "Invalid cell in RPLACA: `" cell "` (" (type cell) ")") + {:cause :bad-value + :detail :rplaca})))) + +;; RPLACD + +(defn RPLACD + "Replace the CDR pointer of this `cell` with this `value`. Dangerous, should + really not exist, but does in Lisp 1.5 (and was important for some + performance hacks in early Lisps)" + [^ConsCell cell value] + (if + (instance? ConsCell cell) + (if + (or + (instance? ConsCell value) + (number? value) + (symbol? value) + (= value NIL)) + (do + (.setCdr cell value) + cell) + (throw (ex-info + (str "Invalid value in RPLACD: `" value "` (" (type value) ")") + {:cause :bad-value + :detail :rplaca}))) + (throw (ex-info + (str "Invalid cell in RPLACD: `" cell "` (" (type cell) ")") + {:cause :bad-value + :detail :rplaca})))) + +;; PLUS + + +;; MINUS + +;; DIFFERENCE + +;; QUOTIENT + +;; REMAINDER + +;; ADD1 + +;; SUB1 + +;; MAX + +;; MIN + +;; RECIP + +;; FIXP + +;; NUMBERP + +;; diff --git a/src/beowulf/read.clj b/src/clojure/beowulf/read.clj similarity index 99% rename from src/beowulf/read.clj rename to src/clojure/beowulf/read.clj index 7490911..6e66fef 100644 --- a/src/beowulf/read.clj +++ b/src/clojure/beowulf/read.clj @@ -278,7 +278,7 @@ (if (coll? p) (case (first p) - :λ "LAMBDA" + :λ 'LAMBDA :λexpr (make-cons-cell (generate (nth p 1)) (make-cons-cell (generate (nth p 2)) diff --git a/src/java/beowulf/substrate/ConsCell.java b/src/java/beowulf/substrate/ConsCell.java new file mode 100644 index 0000000..63a12e5 --- /dev/null +++ b/src/java/beowulf/substrate/ConsCell.java @@ -0,0 +1,243 @@ +package beowulf.substrate; + +import clojure.lang.*; + +import java.lang.Number; +//import beowulf.cons_cell.NIL; + +/** + *

+ * A cons cell - a tuple of two pointers - is the fundamental unit of Lisp store. + *

+ *

+ * Implementing mutable data in Clojure if hard - deliberately so. + * But Lisp 1.5 cons cells need to be mutable. This class is part of thrashing + * around trying to find a solution. In theory it should be possible to make + * instance variables of a `deftype` mutable by supplying the meta-data tag + * :unsynchronized-mutable, but I failed to make that work. + *

+ */ +public class ConsCell + implements clojure.lang.IPersistentCollection, + clojure.lang.ISeq, + clojure.lang.Seqable, + clojure.lang.Sequential { + + /** + * The car of a cons cell can't be just any object; it needs to be + * a number, a symbol or a cons cell. But as there is no common superclass + * or interface for those things, we use Object here and specify the + * types of objects which can be stored in the constructors and setter + * methods. + */ + private Object car; + + /** + * The car of a cons cell can't be just any object; it needs to be + * a number, a symbol or a cons cell. But as there is no common superclass + * or interface for those things, we use Object here and specify the + * types of objects which can be stored in the constructors and setter + * methods. + */ + private Object cdr; + + /** + * Construct a new ConsCell object with this `car` and this `cdr`. + * + * @param car + * @param cdr + * @throws IllegalArgumentException if either `car` or `cdr` is not one + * of ConsCell, Symbol, Number + */ + public ConsCell(Object car, Object cdr) { + if (car instanceof ConsCell || car instanceof Number || car instanceof Symbol) { + this.car = car; + } else { + StringBuilder bob = new StringBuilder("Invalid CAR value (`") + .append(car.toString()).append("`; ") + .append(car.getClass().getName()).append(") passed to CONS"); + throw new IllegalArgumentException(bob.toString()); + } + if (cdr instanceof ConsCell || cdr instanceof Number || cdr instanceof Symbol) { + this.cdr = cdr; + } else { + StringBuilder bob = new StringBuilder("Invalid CDR value (`") + .append(cdr.toString()).append("`; ") + .append(cdr.getClass().getName()).append(") passed to CONS"); + throw new IllegalArgumentException(bob.toString()); + } + } + + public Object getCar() { + return this.car; + } + + public Object getCdr() { + return this.cdr; + } + + public ConsCell setCar(ConsCell c) { + this.car = c; + return this; + } + + public ConsCell setCdr(ConsCell c) { + this.cdr = c; + return this; + } + + public ConsCell setCar(java.lang.Number n) { + this.car = n; + return this; + } + + public ConsCell setCdr(java.lang.Number n) { + this.cdr = n; + return this; + } + + public ConsCell setCar(clojure.lang.Symbol s) { + this.car = s; + return this; + } + + public ConsCell setCdr(clojure.lang.Symbol s) { + this.cdr = s; + return this; + } + + @Override + public boolean equals(Object other) { + boolean result; + + if (other instanceof IPersistentCollection) { + ISeq s = ((IPersistentCollection) other).seq(); + + result = this.car.equals(s.first()) && + this.cdr instanceof ConsCell && + ((ISeq) this.cdr).equiv(s.more()); + } else { + result = false; + } + + return result; + } + + @Override + public String toString() { + StringBuilder bob = new StringBuilder("("); + + for (Object d = this; d instanceof ConsCell; d = ((ConsCell) d).cdr) { + ConsCell cell = (ConsCell) d; + bob.append(cell.car.toString()); + + if (cell.cdr instanceof ConsCell) { + bob.append(" "); + } else if (cell.cdr.toString().equals("NIL")) { + /* That's an ugly hack to work around the fact I can't currently + * get a handle on the NIL symbol itself. In theory, nothing else + * in Lisp 1.5 should have the print-name `NIL`.*/ + bob.append(")"); + } else { + bob.append(" . ").append(cell.cdr.toString()).append(")"); + } + } + + return bob.toString(); + } + + /* IPersistentCollection interface implementation */ + + @Override + public int count() { + int result = 1; + ConsCell cell = this; + + while (cell.cdr instanceof ConsCell) { + result ++; + cell = (ConsCell)cell.cdr; + } + + return result; + } + + @Override + /** + * `empty` is completely undocumented, I'll return `null` until something breaks. + */ + public IPersistentCollection empty() { + return null; + } + + /** + * God alone knows what `equiv` is intended to do; it's completely + * undocumented. But in PersistentList it's simply a synonym for 'equals', + * and that's what I'll implement. + */ + @Override + public boolean equiv(Object o) { + return this.equals(o); + } + + /* ISeq interface implementation */ + @Override + public Object first() { + return this.car; + } + + @Override + public ISeq next() { + ISeq result; + + if (this.cdr instanceof ConsCell) { + result = (ISeq) this.cdr; + } else { + result = null; + } + + return result; + } + + @Override + public ISeq more() { + ISeq result; + + if (this.cdr instanceof ConsCell) { + result = (ISeq) this.cdr; + } else { + result = null; + } + + return result; + } + + /** + * Return a new cons cell comprising the object `o` as car, + * and myself as cdr. Hopefully by declaring the return value + * `ConsCell` I'll satisfy both the IPersistentCollection and the + * ISeq interfaces. + */ + @Override + public ConsCell cons(Object o) { + if (o instanceof ConsCell) { + return new ConsCell((ConsCell) o, this); + } else if (o instanceof Number) { + return new ConsCell((Number) o, this); + } else if (o instanceof Symbol) { + return new ConsCell((Symbol) o, this); + } else { + throw new IllegalArgumentException("Unrepresentable argument passed to CONS"); + } + } + + /* Seqable interface */ + @Override + public ISeq seq() { + return this; + } + + /* Sequential interface is just a marker and does not require us to + * implement anything */ + + +} diff --git a/test/beowulf/bootstrap_test.clj b/test/beowulf/bootstrap_test.clj index 25ac23d..0a2d732 100644 --- a/test/beowulf/bootstrap_test.clj +++ b/test/beowulf/bootstrap_test.clj @@ -75,7 +75,7 @@ (is (= actual expected) "B is CDR of (A . B)")) (let [expected 'B actual (CDR (gsp "(A B C D)"))] - (is (instance? beowulf.cons_cell.ConsCell actual) + (is (instance? beowulf.substrate.ConsCell actual) "CDR of (A B C D) is a cons cell") (is (= (CAR actual) expected) "the CAR of that cons-cell is B")) (is (thrown-with-msg? diff --git a/test/beowulf/cons_cell_test.clj b/test/beowulf/cons_cell_test.clj index 7476db9..3a026a9 100644 --- a/test/beowulf/cons_cell_test.clj +++ b/test/beowulf/cons_cell_test.clj @@ -1,16 +1,16 @@ -(ns beowulf.core-test +(ns beowulf.cons-cell-test (:require [clojure.test :refer :all] [beowulf.cons-cell :refer :all])) (deftest cons-cell-tests (testing "make-cons-cell" (let [expected "(A . B)" - actual (print-str (beowulf.cons_cell.ConsCell. 'A 'B))] + actual (print-str (beowulf.substrate.ConsCell. 'A 'B))] (is (= actual expected) "Cons cells should print as cons cells, natch.")) (let [expected "(A . B)" actual (print-str (make-cons-cell 'A 'B))] (is (= actual expected) "Even if build with the macro.")) - (let [expected beowulf.cons_cell.ConsCell + (let [expected beowulf.substrate.ConsCell actual (print-str (make-cons-cell 'A 'B))] (is (= actual expected) "And they should be cons cells.")) ) @@ -19,37 +19,34 @@ actual (print-str (make-beowulf-list '(A (B C) (D E (F) G) H)))] (is (= actual expected) "Should work for clojure lists, recursively.")) (let [expected "(A (B C) (D E (F) G) H)" - actual (print-str (make-beowulf-list [A [B C] [D E [F] G] H]))] + actual (print-str (make-beowulf-list ['A ['B 'C] ['D 'E ['F] 'G] 'H]))] (is (= actual expected) "Should work for vectors, too.")) (let [expected "NIL" actual (print-str (make-beowulf-list []))] - (is (= actual expected) "An empty sequence is NIL.")) - (let [expected beowulf.cons_cell.ConsCell - actual (make-beowulf-list '(A (B C) (D E (F) G) H))] - (is (= actual expected) "A beowulf list is made of cons cells."))) + (is (= actual expected) "An empty sequence is NIL."))) (testing "pretty-print" (let [expected "(A\n (B C)\n (D E (F) G) H)" - actual (pretty-print (make-beowulf-list '(A (B C) (D E (F) G) H)) 20 0)] + actual (with-out-str (pretty-print (make-beowulf-list '(A (B C) (D E (F) G) H)) 20 0))] (is (= actual expected))) - (let [expected "(A (B C) (D E (F) G) H)" - actual (pretty-print (make-beowulf-list '(A (B C) (D E (F) G) H)))] - (is (= actual expected)))) - (testing "count" - (let [expected 4 - actual (count (make-beowulf-list '(A (B C) (D E (F) G) H)) 20 0)] - (is (= actual expected))) - (let [expected 1 - actual (count (make-beowulf-list '(A)))] - (is (= actual expected))) - (let [expected 1 - actual (count (make-cons-cell 'A 'B))] + (let [expected "(A (B C) (D E (F) G) H)\n" + actual (with-out-str (pretty-print (make-beowulf-list '(A (B C) (D E (F) G) H))))] (is (= actual expected)))) +;; (testing "count" +;; (let [expected 4 +;; actual (.count (make-beowulf-list '(A (B C) (D E (F) G) H)) 20 0)] +;; (is (= actual expected))) +;; (let [expected 1 +;; actual (.count (make-beowulf-list '(A)))] +;; (is (= actual expected))) +;; (let [expected 1 +;; actual (.count (make-cons-cell 'A 'B))] +;; (is (= actual expected)))) (testing "sequence functions" (let [expected "A" actual (print-str (first (make-beowulf-list '(A (B C) (D E (F) G) H))))] (is (= actual expected))) (let [expected "((B C) (D E (F) G) H)" - actual (print-str (more (make-beowulf-list '(A (B C) (D E (F) G) H))))] + actual (print-str (.more (make-beowulf-list '(A (B C) (D E (F) G) H))))] (is (= actual expected))) (let [expected "((B C) (D E (F) G) H)" actual (print-str (next (make-beowulf-list '(A (B C) (D E (F) G) H))))] diff --git a/test/beowulf/host_test.clj b/test/beowulf/host_test.clj new file mode 100644 index 0000000..777bd36 --- /dev/null +++ b/test/beowulf/host_test.clj @@ -0,0 +1,27 @@ +(ns beowulf.host-test + (:require [clojure.math.numeric-tower :refer [abs]] + [clojure.test :refer :all] + [beowulf.cons-cell :refer [make-beowulf-list make-cons-cell NIL T F]] + [beowulf.bootstrap :refer [CDR]] + [beowulf.host :refer :all] + [beowulf.read :refer [gsp]])) + +(deftest destructive-change-test + (testing "RPLACA" + (let + [l (make-beowulf-list '(A B C D E)) + target (CDR l) + expected "(A F C D E)" + actual (do (RPLACA target 'F) (print-str l))] + (is (= actual expected))) + ) + (testing "RPLACA" + (let + [l (make-beowulf-list '(A B C D E)) + target (CDR l) + expected "(A B . F)" + actual (do (RPLACD target 'F) (print-str l))] + (is (= actual expected))) + ) + ) +