simon/beowulf
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Pure Clojure solution to the rplaca/rplacd problem.

Browse source
This commit is contained in:
Simon Brooke 2019-08-23 11:16:27 +01:00
parent ffa3ecd1fe
commit 3d2c524f3f
2 changed files with 127 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/beowulf/bootstrap.clj
View file

@ -58,7 +58,7 @@
[x] [x]
(cond (cond
(= x NIL) NIL (= x NIL) NIL
(instance? beowulf.cons_cell.ConsCell x) (.CAR x) (instance? beowulf.cons_cell.ConsCell x) (.first x)
:else :else
(throw (throw
(Exception. (Exception.
@ -70,7 +70,7 @@
[x] [x]
(cond (cond
(= x NIL) NIL (= x NIL) NIL
(instance? beowulf.cons_cell.ConsCell x) (.CDR x) (instance? beowulf.cons_cell.ConsCell x) (.getCdr x)
:else :else
(throw (throw
(Exception. (Exception.
@ -85,8 +85,8 @@
(= l NIL) NIL (= l NIL) NIL
(empty? path) l (empty? path) l
:else (case (last path) :else (case (last path)
\a (uaf (CAR l) (butlast path)) \a (uaf (.first l) (butlast path))
\d (uaf (CDR l) (butlast path))))) \d (uaf (.getCdr l) (butlast path)))))
(defn CAAR [x] (uaf x (seq "aa"))) (defn CAAR [x] (uaf x (seq "aa")))
(defn CADR [x] (uaf x (seq "ad"))) (defn CADR [x] (uaf x (seq "ad")))

214
src/beowulf/cons_cell.clj
View file

@ -3,47 +3,79 @@
Lisp 1.5 lists do not necessarily have a sequence as their CDR, so Lisp 1.5 lists do not necessarily have a sequence as their CDR, so
cannot be implemented on top of Clojure lists.") cannot be implemented on top of Clojure lists.")
;; (def NIL (def NIL
;; "The canonical empty list symbol." "The canonical empty list symbol."
;; (symbol "NIL")) (symbol "NIL"))
;; (def T (def T
;; "The canonical true value." "The canonical true value."
;; (symbol "T")) ;; true. (symbol "T")) ;; true.
;; (def F (def F
;; "The canonical false value - different from `NIL`, which is not canonically "The canonical false value - different from `NIL`, which is not canonically
;; false in Lisp 1.5." false in Lisp 1.5."
;; (symbol "F")) ;; false as distinct from nil (symbol "F")) ;; false as distinct from nil
(defprotocol MutableSequence
"Like a sequence, but mutable."
(rplaca
[this value]
"replace the first element of this sequence with this value")
(rplacd
[this value]
"replace the rest (but-first; cdr) of this sequence with this value")
(getCdr
[this]
"like `more`, q.v., but returns List `NIL` not Clojure `nil` when empty." ))
(deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR] (deftype ConsCell [^:unsynchronized-mutable CAR ^:unsynchronized-mutable CDR]
MutableSequence
(rplaca [this value] (rplaca [this value]
(if (if
(or (or
(instance? beowulf.cons_cell.ConsCell value) (satisfies? MutableSequence value) ;; can't reference
;; beowulf.cons_cell.ConsCell,
;; because it is not yet
;; defined
(number? value) (number? value)
(symbol? value)) (symbol? value))
(do (do
(set! (. cell CAR) value) (set! (. this CAR) value)
cell) this)
(throw (ex-info (throw (ex-info
(str "Invalid value in RPLACA: `" value "` (" (type value) ")") (str "Invalid value in RPLACA: `" value "` (" (type value) ")")
{:cause :bad-value {:cause :bad-value
:detail :rplaca})))) :detail :rplaca}))))
(rplacd [this value]
(if
(or
(satisfies? MutableSequence value)
(number? value)
(symbol? value))
(do
(set! (. this CDR) value)
this)
(throw (ex-info
(str "Invalid value in RPLACD: `" value "` (" (type value) ")")
{:cause :bad-value
:detail :rplaca}))))
(getCdr [this]
(. this CDR))
clojure.lang.ISeq clojure.lang.ISeq
(cons [this x] (ConsCell. x this)) (cons [this x] (ConsCell. x this))
(first [this] (.CAR this)) (first [this] (.CAR this))
;; next and more must return ISeq: ;; next and more must return ISeq:
;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java ;; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/ISeq.java
(more [this] (if (more [this] (if
(seq? (.CDR this)) (seq? (.getCdr this))
(.CDR this) (.getCdr this)
clojure.lang.PersistentList/EMPTY)) clojure.lang.PersistentList/EMPTY))
(next [this] (if (next [this] (if
(seq? (.CDR this)) (seq? (.getCdr this))
(.CDR this) (.getCdr this)
nil ;; next returns nil when empty nil ;; next returns nil when empty
)) ))
@ -56,8 +88,8 @@
clojure.lang.IPersistentCollection clojure.lang.IPersistentCollection
(count [this] (if (count [this] (if
(coll? (.CDR this)) (coll? (.getCdr this))
(inc (.count (.CDR this))) (inc (.count (.getCdr this)))
1)) 1))
(empty [this] false) ;; a cons cell is by definition not empty. (empty [this] false) ;; a cons cell is by definition not empty.
(equiv [this other] (if (equiv [this other] (if
@ -71,83 +103,83 @@
(= (first this) (first other))) (= (first this) (first other)))
(if (if
(and (and
(seq? (rest this)) (seq? (.getCdr this))
(seq? (rest other))) (seq? (.getCdr other)))
(.equiv (rest this) (rest other)) (.equiv (.getCdr this) (.getCdr other))
(= (rest this) (rest other)))) (= (.getCdr this) (.getCdr other))))
false))) false)))
;; (defn- to-string (defn- to-string
;; "Printing ConsCells gave me a *lot* of trouble. This is an internal function "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 used by the print-method override (below) in order that the standard Clojure
;; `print` and `str` functions will print ConsCells correctly. The argument `print` and `str` functions will print ConsCells correctly. The argument
;; `cell` must, obviously, be an instance of `ConsCell`." `cell` must, obviously, be an instance of `ConsCell`."
;; [cell] [cell]
;; (loop [c cell (loop [c cell
;; n 0 n 0
;; s "("] s "("]
;; (if (if
;; (instance? beowulf.cons_cell.ConsCell c) (instance? beowulf.cons_cell.ConsCell c)
;; (let [car (.CAR c) (let [car (.first c)
;; cdr (.CDR c) cdr (.getCdr c)
;; cons? (instance? beowulf.cons_cell.ConsCell cdr) cons? (instance? beowulf.cons_cell.ConsCell cdr)
;; ss (str ss (str
;; s s
;; (to-string car) (to-string car)
;; (cond (cond
;; cons? cons?
;; " " " "
;; (or (nil? cdr) (= cdr 'NIL)) (or (nil? cdr) (= cdr NIL))
;; ")" ")"
;; :else :else
;; (str " . " (to-string cdr) ")")))] (str " . " (to-string cdr) ")")))]
;; (if (if
;; cons? cons?
;; (recur cdr (inc n) ss) (recur cdr (inc n) ss)
;; ss)) ss))
;; (str c)))) (str c))))
;; (defn pretty-print (defn pretty-print
;; "This isn't the world's best pretty printer but it sort of works." "This isn't the world's best pretty printer but it sort of works."
;; ([^beowulf.cons_cell.ConsCell cell] ([^beowulf.cons_cell.ConsCell cell]
;; (println (pretty-print cell 80 0))) (println (pretty-print cell 80 0)))
;; ([^beowulf.cons_cell.ConsCell cell width level] ([^beowulf.cons_cell.ConsCell cell width level]
;; (loop [c cell (loop [c cell
;; n (inc level) n (inc level)
;; s "("] s "("]
;; (if (if
;; (instance? beowulf.cons_cell.ConsCell c) (instance? beowulf.cons_cell.ConsCell c)
;; (let [car (.CAR c) (let [car (.first c)
;; cdr (.CDR c) cdr (.getCdr c)
;; cons? (instance? beowulf.cons_cell.ConsCell cdr) cons? (instance? beowulf.cons_cell.ConsCell cdr)
;; print-width (count (print-str c)) print-width (count (print-str c))
;; indent (apply str (repeat n " ")) indent (apply str (repeat n " "))
;; ss (str ss (str
;; s s
;; (pretty-print car width n) (pretty-print car width n)
;; (cond (cond
;; cons? cons?
;; (if (if
;; (< (+ (count indent) print-width) width) (< (+ (count indent) print-width) width)
;; " " " "
;; (str "\n" indent)) (str "\n" indent))
;; (or (nil? cdr) (= cdr 'NIL)) (or (nil? cdr) (= cdr NIL))
;; ")" ")"
;; :else :else
;; (str " . " (pretty-print cdr width n) ")")))] (str " . " (pretty-print cdr width n) ")")))]
;; (if (if
;; cons? cons?
;; (recur cdr n ss) (recur cdr n ss)
;; ss)) ss))
;; (str c))))) (str c)))))
;; (defmethod clojure.core/print-method (defmethod clojure.core/print-method
;; ;;; I have not worked out how to document defmethod without blowing up the world. ;;; I have not worked out how to document defmethod without blowing up the world.
;; beowulf.cons_cell.ConsCell beowulf.cons_cell.ConsCell
;; [this writer] [this writer]
;; (.write writer (to-string this))) (.write writer (to-string this)))
(defmacro make-cons-cell (defmacro make-cons-cell