Commit a89e75a4 authored by  Hayley Patton's avatar Hayley Patton 🐢

Separate rewriting metaclass to make MOP less weird

parent d16152db
......@@ -5,7 +5,8 @@
(declare (string text))
(digest-sequence :sha256 (babel:string-to-octets text :encoding :utf-8)))
(defun hash-bytes (bytes)
(digest-sequence :sha256 (subseq bytes 0 (length bytes))))
(digest-sequence :sha256 (coerce (subseq bytes 0 (length bytes))
'(vector (unsigned-byte 8)))))
(defun base-hash-object (object &key (emit-signatures t))
(hash-bytes (binary-render-object object :emit-signatures emit-signatures
......
......@@ -7,9 +7,14 @@
(defgeneric netfarm-class-presentation-script (class)
(:method ((class standard-class)) nil))
;;; The new, MOP-backed, Netfarm object implementation.
(defclass object-metaclass (rewriting-metaclass-mixin standard-class)
())
(defclass netfarm-class (standard-class)
(defmethod closer-mop:validate-superclass ((class object-metaclass)
(standard-class standard-class))
t)
(defclass netfarm-class (object-metaclass)
((presentation-script :initform nil :initarg
:presentation-script
:reader netfarm-class-presentation-script)
......@@ -74,28 +79,16 @@ Providing the class option (:scripts script ...) will attach the initialisation
(:method ((class netfarm-class))
(hash-object* (class->schema class))))
(defclass netfarm-slot (closer-mop:standard-direct-slot-definition)
((computed :initarg :computed :initform nil)
(documentation :initarg :documentation
:reader slot-documentation)
(netfarm-name :initarg :netfarm-name
:reader slot-netfarm-name)))
(defmethod print-object ((slot netfarm-slot) stream)
(print-unreadable-object (slot stream :type t)
(format stream "~s" (slot-netfarm-name slot))))
(defclass netfarm-computed-slot (netfarm-slot)
())
(defclass object ()
(defclass object (rewriting-information-mixin)
((metadata :initarg :metadata :initform (make-hash-table :test 'equal)
:reader object-metadata)
(signatures :initarg :signatures :initform nil :accessor object-signatures)
(source :initarg :source :initform nil :accessor object-source)))
(signatures :initarg :signatures :initform nil :accessor object-signatures))
(:metaclass object-metaclass))
(defmethod closer-mop:class-direct-superclasses ((class netfarm-class))
(append (remove (find-class 'standard-object) (call-next-method))
(list (find-class 'object)
(find-class 'standard-object))))
(list (find-class 'object)
(find-class 'standard-object))))
(defgeneric netfarm-slots (class)
(:method (class) '())
......@@ -106,16 +99,13 @@ Providing the class option (:scripts script ...) will attach the initialisation
(loop for superclass in (closer-mop:class-direct-superclasses class)
append (netfarm-slots superclass)))))
(defmethod closer-mop:validate-superclass ((class netfarm-class)
(standard-class standard-class))
t)
(defun find-effective-slot-definition (class name)
(find name
(closer-mop:class-slots class)
:key #'closer-mop:slot-definition-name))
(defmethod closer-mop:finalize-inheritance :after ((class netfarm-class))
"Populate the slot and computed-slot tables."
(let ((slot-table (make-string-hash-table))
(computed-slot-table (make-string-hash-table)))
(labels ((maybe-add-class-slots (class)
......
(in-package :netfarm)
(defvar *rewrite-references?* t)
(defclass rewriting-metaclass-mixin ()
()
(:documentation "A metaclass mixin that \"rewrites\" its classes' instances' slots, replacing all references R with (funcall (object-source <instance>) (reference-hash R))."))
;;; Methods to automagically rewrite object graphs in slots to remove references.
(defclass rewriting-information-mixin ()
((source :initarg :source :initform nil :accessor object-source)))
(defvar *rewrite-references?* t
"Should we rewrite references?")
(defun overwrite-instance (target source)
"Overwrite an object TARGET by changing its class to (CLASS-OF SOURCE), and then binding its slots to those of SOURCE."
(let ((source-class (class-of source)))
(change-class target source-class)
(dolist (slot (closer-mop:class-slots source-class))
......@@ -27,7 +34,11 @@
(overwrite-instance object
(funcall object-source-function
(reference-hash object)))
(initialize-instance object)))))))
(initialize-instance object))
(hash-table
(maphash (lambda (key value)
(push value to-visit))
object)))))))
(declaim (inline maybe-rewrite-graph))
(defun maybe-rewrite-graph (object graph-cons)
......@@ -38,14 +49,15 @@
(setf (car graph-cons) t))
(cdr graph-cons))
;;; Methods to automagically rewrite object graphs in slots to remove references.
(defmethod closer-mop:slot-value-using-class :around
((class netfarm-class) object slot)
((class rewriting-metaclass-mixin) object slot)
(if (eq (closer-mop:slot-definition-name slot) 'source)
(call-next-method)
(maybe-rewrite-graph object (call-next-method))))
(defmethod (setf closer-mop:slot-value-using-class) :around
(new-value (class netfarm-class) object slot)
(new-value (class rewriting-metaclass-mixin) object slot)
(if (eq (closer-mop:slot-definition-name slot) 'source)
(call-next-method)
(call-next-method (cons nil new-value)
......
(in-package :netfarm)
(defvar *slot-blacklist* '(signatures source)
"Slots which should not be deep-copied.")
(defvar *shallow-slots* '(source)
"Slots which should be shallow-copied. This should be a subset of *SLOT-BLACKLIST*.")
(defgeneric %deep-copy-object (object callback)
(:method (garbage callback)
(warn "Can't copy ~s" garbage)
......@@ -27,8 +32,16 @@
slot)
slot-value))))
(funcall callback new-object)
;; Shallow copy the shallow slots.
(loop for slot-name in *shallow-slots*
when (slot-boundp object slot-name)
do (setf (slot-value new-object slot-name)
(slot-value object slot-name)))
;; Queue the non-blacklisted bound slots for copying.
(loop for slot in (closer-mop:class-slots class)
when (closer-mop:slot-boundp-using-class class object slot)
when (and (closer-mop:slot-boundp-using-class class object slot)
(not (member (closer-mop:slot-definition-name slot)
*slot-blacklist*)))
collect (cons (closer-mop:slot-value-using-class class
object
slot)
......@@ -46,6 +59,7 @@
(lambda (cdr)
(setf (cdr new-cons) cdr))))))
(:method ((vector vector) callback)
;; This should be a vector of (unsigned-byte 8), which we don't copy.
(funcall callback (alexandria:copy-array vector))
'())
(:method ((null null) callback)
......
......@@ -24,7 +24,8 @@
(defclass inbuilt-netfarm-class (netfarm-class)
((names :initarg :schema-names :reader netfarm-class-schema-names))
(:documentation "A class for definining inbuilt Netfarm classes (which have names that are not hash names). Don't ever ever ever use this outside of the Netfarm system definition, or you will create inconsistent state w.r.t the rest of the world and no one will like you."))
(:documentation "A class for definining inbuilt Netfarm classes (which have names that are not hash names).
Don't ever ever ever use this outside of the Netfarm system definition, or you will create inconsistent state w.r.t the rest of the world and no one will like you."))
(defmethod initialize-instance :after ((class inbuilt-netfarm-class) &key)
(dolist (name (netfarm-class-schema-names class))
......
......@@ -9,15 +9,17 @@
(:file "macros")
(:module "Codecs"
:depends-on ("package" "macros")
:serial t
:components ((:file "base64")
(:file "codecs")))
(:module "Objects"
:depends-on ("package" "macros")
:serial t
:components ((:file "hash")
(:module "MOP"
:components ((:file "netfarm-class")
:components ((:file "rewrite-references")
(:file "netfarm-class")
(:file "netfarm-slot")))
(:file "rewrite-references")
(:file "objects")
(:file "schema")
(:file "type-specifiers")
......@@ -26,6 +28,7 @@
(:file "deep-copy")))
(:module "Scripts"
:depends-on ("Objects")
:serial t
:components ((:file "package")
(:module "Script-machine"
:components ((:file "conditions")
......@@ -39,7 +42,7 @@
(:file "objects")
(:file "assemble")
(:file "define-script")))))
(:file "Objects/inbuilt-schemas")
(:file "Objects/inbuilt-schemas" :depends-on ("Objects"))
(:module "Text-format"
:depends-on ("Codecs" "Objects")
:components ((:file "new-parser")
......@@ -50,5 +53,6 @@
(:file "renderer")))
(:module "Crypto"
:depends-on ("Binary-format")
:serial t
:components ((:file "hash")
(:file "keys" :depends-on ("hash"))))))
(:file "keys")))))
......@@ -5,8 +5,7 @@
(netfarm-scripts:define-script *two-plus-two* ()
(:procedure 0) (byte 2) dup + return)
(netfarm-scripts:define-script *also-fairly-basic-maths*
"also-fairly-basic-maths" ()
(netfarm-scripts:define-script *also-fairly-basic-maths* ()
(:procedure 0) (byte 2) (byte 3) < return)
(defmacro should-return ((script-name &rest arguments) &rest values)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment