From 877e9ba00a0cb7b4f67413ddc1ad7b40f34d80b9 Mon Sep 17 00:00:00 2001
From: Simon Brooke <simon@journeyman.cc>
Date: Fri, 23 Aug 2019 11:34:42 +0100
Subject: [PATCH] Added unit tests for RPLACA and RPLACD

---
 src/beowulf/cons_cell.clj  | 19 +++++++-----
 src/beowulf/host.clj       | 59 +++++++++++++++++++++++++++++++++++---
 test/beowulf/host_test.clj | 27 +++++++++++++++++
 3 files changed, 94 insertions(+), 11 deletions(-)
 create mode 100644 test/beowulf/host_test.clj

diff --git a/src/beowulf/cons_cell.clj b/src/beowulf/cons_cell.clj
index 04898dc..e4b2fba 100644
--- a/src/beowulf/cons_cell.clj
+++ b/src/beowulf/cons_cell.clj
@@ -1,7 +1,8 @@
 (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.")
+  Lisp 1.5 lists do not necessarily have a sequence as their CDR, and
+  must have both CAR and CDR mutable, so cannot be implemented on top
+  of Clojure lists.")
 
 (def NIL
   "The canonical empty list symbol."
@@ -29,15 +30,19 @@
     "like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty." ))
 
 (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.
   MutableSequence
 
-    (rplaca [this value]
+  (rplaca [this value]
           (if
             (or
               (satisfies? MutableSequence value) ;; can't reference
-                                                 ;; beowulf.cons_cell.ConsCell,
-                                                 ;; because it is not yet
-                                                 ;; defined
+              ;; beowulf.cons_cell.ConsCell,
+              ;; because it is not yet
+              ;; defined
               (number? value)
               (symbol? value))
             (do
@@ -62,7 +67,7 @@
                      {:cause :bad-value
                       :detail :rplaca}))))
   (getCdr [this]
-       (. this CDR))
+          (. this CDR))
 
   clojure.lang.ISeq
   (cons [this x] (ConsCell. x this))
diff --git a/src/beowulf/host.clj b/src/beowulf/host.clj
index 042dc8f..3c32b8b 100644
--- a/src/beowulf/host.clj
+++ b/src/beowulf/host.clj
@@ -1,17 +1,68 @@
 (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.")
+   host language, in this case Clojure."
+  (:require [beowulf.cons-cell :refer [T NIL F]]
+            ;; note hyphen - this is Clojure...
+            )
+  (:import [beowulf.cons_cell ConsCell]
+           ;; note underscore - same namespace, but Java.
+           ))
 
 ;; 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
 
-;; RPLACD
+(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
+      (.rplaca 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}))))
 
-;; PLUS
+(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
+      (.rplacd 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
 
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)))
+    )
+  )
+