001 (ns beowulf.cons-cell
002 "The fundamental cons cell on which all Lisp structures are built.
003 Lisp 1.5 lists do not necessarily have a sequence as their CDR, and
004 must have both CAR and CDR mutable, so cannot be implemented on top
005 of Clojure lists."
006 (:require [beowulf.oblist :refer [NIL]]))
007
008 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
009 ;;;
010 ;;; Copyright (C) 2022-2023 Simon Brooke
011 ;;;
012 ;;; This program is free software; you can redistribute it and/or
013 ;;; modify it under the terms of the GNU General Public License
014 ;;; as published by the Free Software Foundation; either version 2
015 ;;; of the License, or (at your option) any later version.
016 ;;;
017 ;;; This program is distributed in the hope that it will be useful,
018 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
019 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
020 ;;; GNU General Public License for more details.
021 ;;;
022 ;;; You should have received a copy of the GNU General Public License
023 ;;; along with this program; if not, write to the Free Software
024 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
025 ;;;
026 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
027
028 (declare cons-cell?)
029
030 (def T
031 "The canonical true value."
032 (symbol "T")) ;; true.
033
034 (def F
035 "The canonical false value - different from `NIL`, which is not canonically
036 false in Lisp 1.5."
037 (symbol "F")) ;; false as distinct from nil
038
039 ;;;; The actual cons-cell ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
040
041 (defprotocol MutableSequence
042 "Like a sequence, but mutable."
043 (rplaca
044 [this value]
045 "replace the first element of this sequence with this value")
046 (rplacd
047 [this value]
048 "replace the rest (but-first; cdr) of this sequence with this value")
049 (getCar
050 [this]
051 "Return the first element of this sequence.")
052 (getCdr
053 [this]
054 "like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty.")
055 (getUid
056 [this]
057 "Returns a unique identifier for this object"))
058
059 (deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR uid]
060 ;; Note that, because the CAR and CDR fields are unsynchronised mutable - i.e.
061 ;; plain old Java instance variables which can be written as well as read -
062 ;; ConsCells are NOT thread safe. This does not matter, since Lisp 1.5 is
063 ;; single threaded.
064 MutableSequence
065
066 (rplaca [this value]
067 (if
068 (or
069 (satisfies? MutableSequence value) ;; can't reference
070 ;; beowulf.cons_cell.ConsCell,
071 ;; because it is not yet
072 ;; defined
073 (cons-cell? value)
074 (number? value)
075 (symbol? value))
076 (do
077 (set! (. this CAR) value)
078 this)
079 (throw (ex-info
080 (str "Uncynlic miercels in RPLACA: `" value "` (" (type value) ")")
081 {:cause :bad-value
082 :detail :rplaca}))))
083
084 (rplacd [this value]
085 (if
086 (or
087 (satisfies? MutableSequence value)
088 (cons-cell? value)
089 (number? value)
090 (symbol? value))
091 (do
092 (set! (. this CDR) value)
093 this)
094 (throw (ex-info
095 (str "Uncynlic miercels in RPLACD: `" value "` (" (type value) ")")
096 {:cause :bad-value
097 :detail :rplaca}))))
098
099 (getCar [this]
100 (. this CAR))
101 (getCdr [this]
102 (. this CDR))
103 (getUid [this]
104 (. this uid))
105
106 clojure.lang.ISeq
107 (cons [this x] (ConsCell. x this (gensym "c")))
108 (first [this] (.CAR this))
109 ;; next and more must return ISeq:
110 ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java
111 (more [this] (if
112 (seq? (.getCdr this))
113 (.getCdr this)
114 clojure.lang.PersistentList/EMPTY))
115 (next [this] (if
116 (seq? (.getCdr this))
117 (.getCdr this)
118 nil ;; next returns nil when empty
119 ))
120
121 clojure.lang.Seqable
122 (seq [this] this)
123
124 ;; for some reason this marker protocol is needed otherwise compiler complains
125 ;; that `nth not supported on ConsCell`
126 clojure.lang.Sequential
127
128 clojure.lang.IPersistentCollection
129 (empty [this] (= this NIL)) ;; a cons cell is by definition not empty.
130 (equiv [this other] (if
131 (seq? other)
132 (and
133 (if
134 (and
135 (seq? (first this))
136 (seq? (first other)))
137 (.equiv (first this) (first other))
138 (= (first this) (first other)))
139 (if
140 (and
141 (seq? (.getCdr this))
142 (seq? (.getCdr other)))
143 (.equiv (.getCdr this) (.getCdr other))
144 (= (.getCdr this) (.getCdr other))))
145 false))
146
147 clojure.lang.Counted
148 (count [this] (loop [cell this
149 result 1]
150 (if
151 (and (coll? (.getCdr cell)) (not= NIL (.getCdr cell)))
152 (recur (.getCdr cell) (inc result))
153 result)))
154
155 java.lang.Object
156 (toString [this]
157 (str "("
158 (. this CAR)
159 (cond
160 (instance? ConsCell (. this CDR)) (str " " (subs (.toString (. this CDR)) 1))
161 (= NIL (. this CDR)) ")"
162 :else (str " . " (. this CDR) ")")))))
163
164 ;;;; Printing. Here be dragons! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
165
166 (defn- to-string
167 "Printing ConsCells gave me a *lot* of trouble. This is an internal function
168 used by the print-method override (below) in order that the standard Clojure
169 `print` and `str` functions will print ConsCells correctly. The argument
170 `cell` must, obviously, be an instance of `ConsCell`."
171 ;; TODO: I am deeply suspicious both of this and the defmethod which depends
172 ;; on it. I *think* they are implicated in the `COPY` bug. If the `toString`
173 ;; override in `ConsCell` was right, neither of these would be necessary.
174 ;; see https://github.com/simon-brooke/beowulf/issues/5
175 [cell]
176 (loop [c cell
177 n 0
178 s "("]
179 (if
180 (instance? beowulf.cons_cell.ConsCell c)
181 (let [car (.first c)
182 cdr (.getCdr c)
183 cons? (and
184 (instance? beowulf.cons_cell.ConsCell cdr)
185 (not (nil? cdr))
186 (not= cdr NIL))
187 ss (str
188 s
189 (to-string car)
190 (cond
191 (or (nil? cdr) (= cdr NIL)) ")"
192 cons? " "
193 :else (str " . " (to-string cdr) ")")))]
194 (if
195 cons?
196 (recur cdr (inc n) ss)
197 ss))
198 (str c))))
199
200 (defmethod clojure.core/print-method
201 ;;; I have not worked out how to document defmethod without blowing up the world.
202 beowulf.cons_cell.ConsCell
203 [this writer]
204 (.write writer (to-string this)))
205
206 (defn pretty-print
207 "This isn't the world's best pretty printer but it sort of works."
208 ([cell]
209 (println (pretty-print cell 80 0)))
210 ([cell width level]
211 (loop [c cell
212 n (inc level)
213 s "("]
214 (if
215 (instance? beowulf.cons_cell.ConsCell c)
216 (let [car (.first c)
217 cdr (.getCdr c)
218 tail? (instance? beowulf.cons_cell.ConsCell cdr)
219 print-width (count (print-str c))
220 indent (apply str (repeat n " "))
221 ss (str
222 s
223 (pretty-print car width n)
224 (cond
225 (or (nil? cdr) (= cdr NIL))
226 ")"
227 tail?
228 (if
229 (< (+ (count indent) print-width) width)
230 " "
231 (str "\n" indent))
232 :else
233 (str " . " (pretty-print cdr width n) ")")))]
234 (if
235 tail?
236 (recur cdr n ss)
237 ss))
238 (str c)))))
239
240 (defn cons-cell?
241 "Is this object `o` a beowulf cons-cell?"
242 [o]
243 (instance? beowulf.cons_cell.ConsCell o))
244
245 (defn make-cons-cell
246 "Construct a new instance of cons cell with this `car` and `cdr`."
247 [car cdr]
248 (try
249 (ConsCell. car cdr (gensym "c"))
250 (catch Exception any
251 (throw (ex-info "Ne meahte cræfte cons cell" {:car car
252 :cdr cdr} any)))))
253
254 (defn make-beowulf-list
255 "Construct a linked list of cons cells with the same content as the
256 sequence `x`."
257 [x]
258 (try
259 (cond
260 (empty? x) NIL
261 (instance? ConsCell x) (make-cons-cell (.getCar x) (.getCdr x))
262 (coll? x) (ConsCell.
263 (if
264 (coll? (first x))
265 (make-beowulf-list (first x))
266 (first x))
267 (make-beowulf-list (rest x))
268 (gensym "c"))
269 :else
270 NIL)
271 (catch Exception any
272 (throw (ex-info "Ne meahte cræfte Beowulf líste"
273 {:content x}
274 any)))))