Commit 6d614997 authored by  Hayley Patton's avatar Hayley Patton 🐢

Rewrite the inbuilt object and class hashing mechanisms

parent 2e74e84e
......@@ -15,11 +15,14 @@
(setf (aref vector n) (funcall function)))
(defgeneric binary-parse-from-type-tag (type-tag function)
(:method ((tag (eql 1)) function)
(defun read-string (function)
(babel:octets-to-string (read-byte-vector function
(read-integer function))
:encoding :utf-8))
(defgeneric binary-parse-from-type-tag (type-tag function)
(:method ((tag (eql 1)) function)
(read-string function))
(:method ((tag (eql 2)) function)
(read-byte-vector function (read-integer function)))
(:method ((tag (eql 3)) function)
......@@ -35,10 +38,8 @@
(loop repeat length
collect (binary-parse-from-function function))))
(:method ((tag (eql 6)) function)
(let ((hash (make-array 32 :element-type '(unsigned-byte 8))))
(dotimes (n 32)
(setf (aref hash n) (funcall function)))
(make-instance 'reference :hash hash)))
(make-instance 'reference
:hash (read-string function)))
(:method ((tag (eql 7)) function)
(declare (ignore function))
......@@ -40,11 +40,17 @@
(dolist (element l)
(binary-render-to-function element function)))
(:method ((r reference) function)
(let ((bytes (babel:string-to-octets (reference-hash r)
:encoding :utf-8)))
(write-type-tag 6 function)
(funcall function (reference-hash r)))
(write-integer (length bytes) function)
(funcall function bytes)))
(:method ((o object) function)
(let ((bytes (babel:string-to-octets (hash-object* o)
:encoding :utf-8)))
(write-type-tag 6 function)
(funcall function (hash-object o)))
(write-integer (length bytes) function)
(funcall function bytes)))
(:method ((x (eql ':true)) function)
(write-type-tag 7 function))
(:method ((x (eql ':false)) function)
......@@ -49,11 +49,9 @@
(define-codec ref
(lambda (reference)
(check-type reference reference)
(bytes->base64 (reference-hash reference)))
(reference-hash reference))
(lambda (string)
(make-instance 'reference
:hash (coerce (subseq (base64->bytes string) 0 32)
'(vector (unsigned-byte 8))))))
(make-instance 'reference :hash string)))
(defun find-codec (name type)
(let ((codec-definition (gethash name *codecs*)))
......@@ -23,7 +23,7 @@
(:method ((vague-object vague-object))
(base-hash-object vague-object))
(:method ((reference reference))
(reference-hash reference)))
(base64->bytes (reference-hash reference))))
(defun hash-object* (object)
"Generate a hash for an object using HASH-OBJECT, but then base64-encode it. This seems common enough to deserve a function."
......@@ -61,11 +61,8 @@ Providing the class option (:scripts script ...) will attach the initialisation
appending (netfarm-class-scripts class))))))
(defmethod initialize-instance :after ((class netfarm-class) &key)
;; This variable is introduced after the MOP stuff is loaded.
(declare (special *netfarm-classes*))
(force-script-data-evaluation class)
(setf (gethash (netfarm-class-name class) *netfarm-classes*)
(intern-class class))
(defmethod reinitialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class))
......@@ -20,6 +20,16 @@
(closer-mop:slot-value-using-class source-class source slot))))
(initialize-instance target)))
(defun find-schema-in-table (hash table)
(alexandria:if-let ((class (gethash hash table)))
(class->schema class)))
(defun reference-replacement (hash function)
"Find an object with a given hash, possibly calling the function if the object is not known internally."
(or (gethash hash *inbuilt-objects*)
(find-schema-in-table hash *inbuilt-classes*)
(find-schema-in-table hash *classes*)
(funcall function hash)))
(defun rewrite-graph (graph object-source-function)
(let ((visited (make-hash-table))
(to-visit (list graph)))
......@@ -31,9 +41,10 @@
(push (car object) to-visit)
(push (cdr object) to-visit))
(assert (stringp (reference-hash object)))
(overwrite-instance object
(funcall object-source-function
(reference-hash object)))
(reference-replacement (reference-hash object)
(initialize-instance object))
(maphash (lambda (key value)
(in-package :netfarm)
;;; Hash consing schema->class
(defvar *classes*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters nil)
"A table that maps schema hashes to Netfarm classes.")
;;; Hash consing class->schema
(defvar *schemas*
(trivial-garbage:make-weak-hash-table :test 'eq
:weakness :value
:weakness-matters nil)
"A table that maps Netfarm classes to schemas.")
(defgeneric intern-class (class)
(:method ((class netfarm-class))
(let ((schema (class->schema class)))
(setf (gethash (hash-object* schema) *classes*) class
(gethash class *schemas*) schema))))
(in-package :netfarm)
;;; Inbuilt objects (not classes)
(defvar *objects*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters t)
"A table that maps hashes to inbuilt objects.")
(defun pin-object (object)
"Mark an object as \"inbuilt\", allowing it to be retrieved via INBUILT-OBJECT."
(setf (gethash (hash-object* object) *objects*)
(defclass named-mixin ()
((inbuilt-name :initarg :inbuilt-name :type string :reader named-mixin-name)))
(defun make-named-instance (class name &rest initargs)
(apply #'make-instance
(make-instance 'standard-class
:direct-superclasses (list class (find-class 'named-mixin)))
:inbuilt-name name
(defvar *inbuilt-objects*
(trivial-garbage:make-weak-hash-table :test 'equal)
"A table that maps names to inbuilt objects.")
(defmethod initialize-instance :after ((object named-mixin) &key)
(setf (gethash (named-mixin-name object) *inbuilt-objects*)
(defun inbuilt-object (hash)
"Returns the inbuilt object with given hash, or returns NIL if there isn't such an object."
(values (gethash hash *objects*)))
(values (gethash hash *inbuilt-objects* nil)))
;;; Inbuilt classes
(defvar *netfarm-classes*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters nil)
"A table that maps schema hashes to Netfarm classes.")
(defvar *inbuilt-classes* (make-hash-table :test 'equal)
"A table that maps names to inbuilt classes.")
(defclass inbuilt-netfarm-class (netfarm-class)
((names :initarg :schema-names :reader netfarm-class-schema-names))
((schema-names :initarg :schema-name :reader inbuilt-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."))
Don't ever ever ever use this outside of the Netfarm system, 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))
(setf (gethash name *netfarm-classes*) class)))
(defmethod netfarm-class-name ((class inbuilt-netfarm-class))
(first (netfarm-class-schema-names class)))
(assert (= (length (inbuilt-netfarm-class-schema-names class)) 1)))
;;; Hash consing class->schema
(defmethod intern-class ((class inbuilt-netfarm-class))
(setf (gethash (netfarm-class-name class) *inbuilt-classes*) class)
(unless (eql (class-name class) 'schema)
;; We can't create the schema of the schema until the class has been bound.
(let ((schema (class->schema class)))
(setf (gethash class *schemas*) schema))))
(defvar *schemas*
(trivial-garbage:make-weak-hash-table :test 'eq
:weakness :value
:weakness-matters nil)
"A table that maps Netfarm classes to schemas.")
(defmethod netfarm-class-name ((class inbuilt-netfarm-class))
(first (inbuilt-netfarm-class-schema-names class)))
(in-package :netfarm)
;;; Some inbuilt classes.
(defclass schema ()
((slots :initarg :slots :reader schema-slots)
(computed-slots :initarg :computed-slots :reader schema-computed-slots)
......@@ -12,13 +11,15 @@
:reader schema-message-script
:documentation "The script that is run when an instance of this schema receives a message. The first procedure in the script is called with the subject object, the object that sent the message, and the message itself as arguments."))
(:metaclass inbuilt-netfarm-class)
(:schema-names "inbuilt@schema"))
(:schema-name "inbuilt@schema"))
(let ((schema-schema (class->schema (find-class 'schema))))
(setf (gethash (find-class 'schema) *schemas*) schema-schema))
(defclass user ()
((sign-key :initarg :sign-key :reader user-sign-key)
(ecdh-key :initarg :ecdh-key :reader user-ecdh-key))
(:metaclass inbuilt-netfarm-class)
(:schema-names "inbuilt@user"))
(:schema-name "inbuilt@user"))
(defclass user-map ()
((antitriples :initarg :antitriples
......@@ -31,4 +32,4 @@
:initform '()
:reader user-map-delegates))
(:metaclass inbuilt-netfarm-class)
(:schema-names "inbuilt@map"))
(:schema-name "inbuilt@map"))
......@@ -10,7 +10,7 @@
(define-tuple reference ()
((hash :read-only t))
"A reference to a hash-named object from a source.")
"A reference to an object.")
(macrolet ((mht () '(make-hash-table :test 'equal)))
(define-tuple vague-object ()
......@@ -74,7 +74,7 @@
(list (vague-object-schema-name vague-object))
(let ((reference-hashes '()))
(map-references (lambda (reference)
(push (bytes->base64 (reference-hash reference))
(push (reference-hash reference)
(in-package :netfarm)
(defvar *netfarm-classes*
(trivial-garbage:make-weak-hash-table :test 'equal
:weakness :value
:weakness-matters nil))
(defvar *schemas*
(trivial-garbage:make-weak-hash-table :test 'eq
:weakness :value
:weakness-matters nil))
(defun apply-class (vague-object class)
"Apply the class CLASS to a VAGUE-OBJECT, matching slot names and types with
keys in the vague-object's values table."
......@@ -44,12 +35,11 @@ keys in the vague-object's values table."
(defun find-netfarm-class (name &optional (error? t))
"Find a Netfarm class with the provided name. If no such class exists and ERROR? is true, a NETFARM-CLASS-NOT-FOUND error will be signalled. If no such class exists and ERROR? is false, NIL will be returned."
(multiple-value-bind (class present?)
(gethash name *netfarm-classes*)
(present? class)
(error? (error 'netfarm-class-not-found :class-name name))
(t nil))))
(or (gethash name *classes*)
(gethash name *inbuilt-classes*)
(if error?
(error 'netfarm-class-not-found :class-name name)
;;; Convert schemas to classes and back.
......@@ -85,7 +75,7 @@ keys in the vague-object's values table."
(defun schema->class (schema &key slot-names)
"Convert a schema into a NETFARM-CLASS. If a class already exists that corresponds to the schema, it is returned. Otherwise, a new schema is returned. If the association list SLOT-NAMES is provided, each slot name will be looked up in the association list, and the values will be used as slot names instead of creating uninterned symbols."
(with-cache ((hash-object* schema) *netfarm-classes* :write-back nil)
(with-cache ((hash-object* schema) *classes* :write-back nil)
(make-instance 'netfarm-class
:name (make-symbol (hash-object* schema))
:documentation (schema-documentation schema)
......@@ -103,7 +93,6 @@ keys in the vague-object's values table."
in (string-hash-table->alist slot-definition-table)
collect (slot-definition->netfarm-slot name slot-definition)))
(defun class->schema (class)
"Convert a NETFARM-CLASS into a schema. If a schema for this class already exists, it is returned."
(with-cache (class *schemas*)
......@@ -5,7 +5,7 @@
(program :initarg :program :reader script-program)
(variables :initarg :variables :reader script-variables))
(:metaclass netfarm::inbuilt-netfarm-class)
(:schema-names "inbuilt@script"))
(:schema-name "inbuilt@script"))
(deftype reasonably-sized-natural ()
"Well, I hope this is a subset of the implementation's FIXNUM type. But still."
......@@ -135,10 +135,10 @@ string; but RENDER-OBJECT will emit Netfarm standard format text."))
(defgeneric render-to-stream (object stream)
(:documentation "Render a Netfarm value to a stream.")
(:method ((ref reference) stream)
(format stream "ref:~a"
(bytes->base64 (reference-hash ref))))
(assert (stringp (reference-hash ref)))
(format stream "ref:~a" (reference-hash ref)))
(:method ((object object) stream)
(format stream "ref:~a" (bytes->base64 (hash-object object))))
(format stream "ref:~a" (hash-object* object)))
(:method ((string integer) stream)
(format stream "integer:~d" string))
(:method ((true (eql :true)) stream)
......@@ -21,11 +21,13 @@
(:file "netfarm-class")
(:file "netfarm-slot")))
(:file "objects")
(:file "schema")
(:file "type-specifiers")
(:file "hash-classes")
(:file "inbuilt-objects")
(:file "schema")
(:file "computed-values")
(:file "deep-copy")))
(:file "deep-copy")
(:file "inbuilt-schemas")))
(:module "Scripts"
:depends-on ("Objects")
:serial t
......@@ -45,7 +47,6 @@
(:module "Reference-side-effects"
:components ((:file "apply-side-effect")
(:file "run-scripts")))))
(:file "Objects/inbuilt-schemas" :depends-on ("Objects"))
(:module "Text-format"
:depends-on ("Codecs" "Objects")
:components ((:file "new-parser")
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