Commit 5029b323 authored by  Hayley Patton's avatar Hayley Patton 🐢

Add documentation to slots, provide slots for computed values in Netfarm classes and schemas

parent 221f8072
......@@ -9,4 +9,5 @@
(push (make-instance 'computed-value
:cause cause
:value value)
(gethash name (object-computed-values-table object)))))
(object-computed-values object name))
t))
......@@ -3,11 +3,14 @@
;;; Some inbuilt classes.
(defclass schema ()
((slots :initarg :slots :accessor schema-slots)
(documentation :initarg :documentation :accessor schema-documentation)
(presentation-script :initarg :presentation-script :accessor schema-presentation-script)
(scripts :initarg :scripts :accessor schema-scripts)
(message-script :initarg :message-script :accessor schema-message-script))
((slots :initarg :slots :reader schema-slots)
(computed-slots :initarg :computed-slots :reader schema-computed-slots)
(documentation :initarg :documentation :reader schema-documentation)
(presentation-script :initarg :presentation-script :reader schema-presentation-script)
(scripts :initarg :scripts :reader schema-scripts)
(message-script :initarg :message-script
: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"))
......
......@@ -2,15 +2,65 @@
;;; The new, MOP-backed, Netfarm object implementation.
(defgeneric netfarm-class-scripts (class)
(:method ((class standard-class)) '()))
(defgeneric netfarm-class-message-script (class)
(:method ((class standard-class)) nil))
(defgeneric netfarm-class-presentation-script (class)
(:method ((class standard-class)) nil))
(defclass netfarm-class (standard-class)
((presentation-script :initform nil :initarg
:presentation-script
:reader netfarm-class-presentation-script)
(scripts :initform '() :initarg :scripts :reader netfarm-class-scripts)
(direct-scripts :initform '()
:initarg :scripts
:reader netfarm-class-direct-scripts)
(scripts :reader netfarm-class-scripts)
(message-script :initform nil
:initarg :message-script
:reader netfarm-class-message-script)
(slot-table :reader netfarm-class-slot-table)))
(slot-table :reader netfarm-class-slot-table)
(computed-slot-table :reader netfarm-class-computed-slot-table))
(:documentation "The metaclass of a class Netfarm knows how to serialise, take OBJECT-VALUE of, and create instance of, as well as a class that Netfarm can get scripts from.
Providing the class option (:scripts script ...) will attach the initialisation scripts to the class, and providing the class option (:message-script script) will attach the message script to the class. Both are evaluated, but not in the lexical environment of the DEFCLASS form because those are not evaluated by DEFCLASS, and we have to evaluate them with EVAL ourselves."))
(defun force-script-data-evaluation (class)
"Evaluate the provided forms that designate scripts, and merge them with the superclasses' scripts."
(setf (slot-value class 'direct-scripts)
(mapcar #'eval (netfarm-class-direct-scripts class))
;; The (singular) presentation script is inherited from the first
;; superclass that has a presentation script.
(slot-value class 'presentation-script)
(if (null (netfarm-class-presentation-script class))
nil
(destructuring-bind (script)
(netfarm-class-presentation-script class)
(eval script)))
;; The (singular) message script is inherited from the first superclass
;; that has a message script.
(slot-value class 'message-script)
(if (null (netfarm-class-message-script class))
(some #'netfarm-class-message-script
(closer-mop:class-direct-superclasses class))
(destructuring-bind (script)
(netfarm-class-message-script class)
(eval script)))
;; The initialisation scripts of a class are the direct scripts of itself
;; and the scripts of its superscripts. This isn't very different to how
;; slots are inherited in CLOS.
(slot-value class 'scripts)
(append (netfarm-class-direct-scripts class)
(loop for class in (closer-mop:class-direct-superclasses class)
appending (netfarm-class-scripts class)))))
(defmethod initialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class)
(setf (gethash (netfarm-class-name class) *netfarm-classes*)
class))
(defmethod reinitialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class))
(defmethod netfarm-class-slot-table :before ((class netfarm-class))
(unless (closer-mop:class-finalized-p class)
......@@ -21,12 +71,29 @@
(bytes->base64 (hash-object (class->schema class)))))
(defclass netfarm-slot (closer-mop:standard-direct-slot-definition)
((netfarm-name :initarg :netfarm-name
((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)
())
(defmethod initialize-instance :around ((slot netfarm-computed-slot)
&rest rest
&key initform name)
(unless (null initform)
(error "Cannot supply an initform for the computed slot ~s"
name))
(apply #'call-next-method slot
:initform '()
:initfunction (constantly '())
rest))
(defmethod initialize-instance :after ((slot netfarm-slot) &key)
;; Generate a netfarm-slot name from the slot's symbol-name.
(unless (slot-boundp slot 'netfarm-name)
......@@ -34,14 +101,16 @@
(string-downcase (closer-mop:slot-definition-name slot)))))
(defmethod closer-mop:direct-slot-definition-class ((class netfarm-class) &rest initargs)
(declare (ignore class initargs))
(find-class 'netfarm-slot))
(declare (ignore class))
(destructuring-bind (&key computed &allow-other-keys) initargs
(if computed
(find-class 'netfarm-computed-slot)
(find-class 'netfarm-slot))))
(macrolet ((mht () '(make-hash-table :test 'equal)))
(defclass object ()
((signatures :initarg :signatures :initform nil :accessor object-signatures)
(metadata :initform (mht) :initarg :metadata :reader object-metadata)
(computed-values :initform (mht) :reader object-computed-values-table)
(source :initarg :source :initform nil :accessor object-source)
(last-hash :initform nil
:accessor object-last-hash))))
......@@ -70,21 +139,39 @@
:key #'closer-mop:slot-definition-name))
(defmethod closer-mop:finalize-inheritance :after ((class netfarm-class))
(let ((slot-table (make-string-hash-table)))
(dolist (class (closer-mop:class-precedence-list class))
(when (typep class 'netfarm-class)
(dolist (slot (closer-mop:class-direct-slots class))
(let ((name (slot-netfarm-name slot)))
(unless (null name)
(if (string-gethash slot-table name)
(error "duplicate slot name: ~s" name)
(setf (string-gethash slot-table name)
(find-effective-slot-definition
class
(closer-mop:slot-definition-name slot)))))))))
(setf (slot-value class 'slot-table) slot-table)))
(declaim (inline find-netfarm-slot map-slots))
(let ((slot-table (make-string-hash-table))
(computed-slot-table (make-string-hash-table)))
(labels ((maybe-add-class-slots (class)
(when (typep class 'netfarm-class)
(dolist (slot (closer-mop:class-direct-slots class))
(maybe-add-slot slot))))
(maybe-add-slot (slot)
(let ((name (slot-netfarm-name slot)))
(unless (null name)
(if (typep slot 'netfarm-computed-slot)
(add-computed-slot slot name)
(add-slot slot name)))))
(add-computed-slot (slot name)
(if (string-gethash computed-slot-table name)
(error "duplicate computed slot name: ~s" name)
(setf (string-gethash computed-slot-table name)
(find-effective-slot-definition
class
(closer-mop:slot-definition-name slot)))))
(add-slot (slot name)
(if (string-gethash slot-table name)
(error "duplicate slot name: ~s" name)
(setf (string-gethash slot-table name)
(find-effective-slot-definition
class
(closer-mop:slot-definition-name slot))))))
(dolist (class (closer-mop:class-precedence-list class))
(maybe-add-class-slots class))
(setf (slot-value class 'slot-table) slot-table
(slot-value class 'computed-slot-table) computed-slot-table))))
(declaim (inline find-netfarm-slot map-slots
find-netfarm-computed-slot map-computed-slots))
(defun find-netfarm-slot (class slot-name)
(etypecase slot-name
(symbol (setf slot-name (string-downcase slot-name)))
......@@ -97,3 +184,16 @@
(loop for bucket across table
do (loop for (name . definition) in bucket
do (funcall function name definition)))))
(defun find-netfarm-computed-slot (class slot-name)
(etypecase slot-name
(symbol (setf slot-name (string-downcase slot-name)))
(string))
(string-gethash (netfarm-class-computed-slot-table class) slot-name))
(defun map-computed-slots (function class)
"Call the function with each computed slot name and definition in the class."
(let ((table (netfarm-class-computed-slot-table class)))
(loop for bucket across table
do (loop for (name . definition) in bucket
do (funcall function name definition)))))
......@@ -22,23 +22,25 @@
(computed-values :initform (mht)))
"A parsed, but not schema-passed, object."))
(defmacro with-slot-definition ((name class object netfarm-name) &body body)
(defmacro with-slot-definition ((name class object netfarm-name &key (find-slot 'find-netfarm-slot)) &body body)
(alexandria:once-only (object netfarm-name)
`(let* ((,class (class-of ,object))
(,name (find-netfarm-slot ,class ,netfarm-name)))
(,name (,find-slot ,class ,netfarm-name)))
(assert ,name () "Slot ~s is not present in the object ~s" ,netfarm-name ,object)
,@body)))
;;; s/slot/object/-modified CLOS accessors & functions that work with Netfarm
;;; slot names rather than symbols.
(declaim (inline object-value (setf object-value) object-boundp object-makunbound))
(declaim (inline object-value (setf object-value)
object-boundp object-makunbound
object-computed-values (setf object-computed-values)))
(defun object-value (object slot-name)
"Get the value of the slot named SLOT-NAME in the object OBJECT."
(with-slot-definition (slot class object slot-name)
(closer-mop:slot-value-using-class class object slot)))
(defun (setf object-value) (new-value object slot-name)
"Set the value of the slot named SLOT-NAME in the object OBJECT to VALUE."
"Set the value of the slot named SLOT-NAME in the object OBJECT to NEW-VALUE."
(with-slot-definition (slot class object slot-name)
(setf (closer-mop:slot-value-using-class class object slot) new-value)))
......@@ -52,6 +54,19 @@
(with-slot-definition (slot class object slot-name)
(closer-mop:slot-makunbound-using-class class object slot)))
(defun object-computed-values (object slot-name)
"Get the computed values of the slot named SLOT-NAME in the object OBJECT."
(with-slot-definition (slot class object slot-name
:find-slot find-netfarm-computed-slot)
(closer-mop:slot-value-using-class class object slot)))
(defun (setf object-computed-values) (new-values object slot-name)
"Set the computed values of the slot named SLOT-NAME in the object OBJECT to NEW-VALUES."
(with-slot-definition (slot class object slot-name
:find-slot find-netfarm-computed-slot)
(setf (closer-mop:slot-value-using-class class object slot)
new-values)))
(defgeneric compute-dependencies (object)
(:documentation "Compute the dependencies of a vague-object, producing a list of object names, or an object, producing a list of objects.")
(:method ((vague-object vague-object))
......
......@@ -46,17 +46,3 @@
(call-next-method)
(call-next-method (cons nil new-value)
class object slot)))
(defun object-computed-value-names (object)
(alexandria:hash-table-keys object))
(defun object-computed-values (object name)
(declare (object object))
(multiple-value-bind (values present?)
(gethash name (object-computed-values-table object))
(if present?
(maybe-rewrite-graph object values)
'())))
(defun (setf object-computed-values) (new-values object name)
(declare (object object))
(setf (gethash name (object-computed-values-table object))
(cons nil new-values)))
......@@ -9,26 +9,6 @@
:weakness :value
:weakness-matters nil))
(defun force-script-data-evaluation (class)
"Evil hack to force script data to be evaluated."
(setf (slot-value class 'scripts)
(mapcar #'eval (netfarm-class-scripts class))
(slot-value class 'presentation-script)
(if (or (null (netfarm-class-presentation-script class))
(not (slot-boundp class 'presentation-script)))
nil
(eval (first (netfarm-class-presentation-script class))))
(slot-value class 'message-script)
(eval (netfarm-class-message-script class))))
(defmethod initialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class)
(setf (gethash (netfarm-class-name class) *netfarm-classes*)
class))
(defmethod reinitialize-instance :after ((class netfarm-class) &key)
(force-script-data-evaluation class))
(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."
......@@ -46,7 +26,11 @@ keys in the vague-object's values table."
slot-definition)
value))
(maphash (lambda (name values)
(setf (object-computed-values new-object name) values))
(setf (object-computed-values new-object name)
(loop for (cause value) in values
collect (make-instance 'computed-value
:cause cause
:value value))))
(vague-object-computed-values vague-object))
new-object))
......@@ -75,34 +59,61 @@ keys in the vague-object's values table."
return (values value t))
(values default nil))
(defun schema-direct-slots (schema slot-names)
(append
(loop for (slot-name . properties) in (schema-slots schema)
collect `(:name ,(or (cdr (assoc slot-name slot-names :test #'string=))
(make-symbol slot-name))
:documentation ,(getf/string "documentation" properties)))
(loop for (slot-name . properties) in (schema-computed-slots schema)
collect `(:name ,(or (cdr (assoc slot-name slot-names :test #'string=))
(make-symbol slot-name))
:computed t
:documentation ,(getf/string "documentation" properties)))))
(defmacro with-cache ((key table &key (write-back t)) &body body)
(alexandria:once-only (key table)
(alexandria:with-gensyms (value present?)
`(multiple-value-bind (,value ,present?)
(gethash ,key ,table)
(if ,present?
,value
,(if write-back
`(setf (gethash ,key ,table)
(progn ,@body))
`(progn ,@body)))))))
(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."
(multiple-value-bind (known-class present?)
(gethash (bytes->base64 (hash-object schema))
*netfarm-classes*)
(if present?
known-class
(make-instance 'netfarm-class
:name (make-symbol (bytes->base64 (hash-object schema)))
:documentation (schema-documentation schema)
:direct-slots (loop for (slot-name . properties) in (schema-slots schema)
collect `(:name ,(or (cdr (assoc slot-name slot-names :test #'string=))
(make-symbol slot-name))
:documentation ,(getf/string "documentation" properties)))
:scripts (schema-scripts schema)
:presentation-script (schema-presentation-script schema)
:message-script (schema-message-script schema)))))
(with-cache ((hash-object* schema) *netfarm-classes* :write-back nil)
(make-instance 'netfarm-class
:name (make-symbol (hash-object* schema))
:documentation (schema-documentation schema)
:direct-slots (schema-direct-slots schema slot-names)
:scripts (schema-scripts schema)
:presentation-script (schema-presentation-script schema)
:message-script (schema-message-script schema))))
(defun slot-definition->netfarm-slot (name slot-definition)
(declare (ignore slot-definition))
`(,name))
(defun slot-definition-table->slot-definitions (slot-definition-table)
(loop for (name . slot-definition)
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."
(multiple-value-bind (known-schema present?)
(gethash class *schemas*)
(if present?
known-schema
(setf (gethash class *schemas*)
(make-instance 'schema
:scripts (netfarm-class-scripts class)
:message-script (netfarm-class-message-script class)
:presentation-script (netfarm-class-presentation-script class)
:documentation (documentation class 'type)
:slots (mapcar (alexandria:compose #'list #'car)
(string-hash-table->alist (netfarm-class-slot-table class))))))))
(with-cache (class *schemas*)
(make-instance 'schema
:computed-slots (slot-definition-table->slot-definitions
(netfarm-class-computed-slot-table class))
:documentation (documentation class 'type)
:message-script (netfarm-class-message-script class)
:presentation-script (netfarm-class-presentation-script class)
:scripts (netfarm-class-scripts class)
:slots (slot-definition-table->slot-definitions
(netfarm-class-slot-table class)))))
......@@ -82,7 +82,7 @@
(eql ',name (first data)))
(cerror "Redefine the opcode"
"The opcode ~d with name ~s is being redefined to ~s"
,number ',name (first data))))
,number (first data) ',name)))
(%define-opcode ,number ,name ,parts ,inputs ,bytes
,declarations
,(make-opcode-lambda parts inputs bytes declarations
......
......@@ -40,6 +40,8 @@ if the value contains calls to codecs or lists."
(loop until (char= (peek-char t stream) #\))
collect (parse stream :allow-codecs allow-codecs)
finally (read-char stream))))
(#\)
(error "unmatched )"))
(#\"
(read-char stream)
(with-output-to-string (accumulator)
......@@ -74,7 +76,7 @@ if the value contains calls to codecs or lists."
(defun parse-segments (segments &key source name)
"Parse the Netfarm block in TEXT. If SOURCE is provided, it is the source of
the generated VAGUE-OBJECT."
(when (not (member (length segments) '(3 4)))
(unless (<= 3 (length segments) 4)
(error 'parser-bad-segment-count
:count (length segments)))
(destructuring-bind (signatures metadata values
......
(in-package :netfarm)
(defun render-hash-table (hash-table stream)
(loop for (key . value)
in (sort (alexandria:hash-table-alist hash-table) #'string< :key #'car)
(loop for ((key . value) . rest?)
on (sort (alexandria:hash-table-alist hash-table) #'string< :key #'car)
do (render key stream)
(write-char #\Space stream)
(render value stream)
(write-char #\Newline stream)))
(when rest?
(write-char #\Newline stream))))
(defun render-slots (object stream)
(let* ((class (class-of object))
......@@ -43,20 +44,42 @@
(write-char #\Newline stream))))
(defun maybe-write-computed-values (object stream)
(let* ((table (etypecase object
(object (object-computed-values-table object))
(vague-object (vague-object-computed-values object))))
(flet ((write-computed-value-list (list stream)
(write-char #\( stream)
(loop for (computed-value . more?) on list
do (write-char #\( stream)
(render-to-stream (computed-value-cause computed-value)
stream)
(write-char #\Space stream)
(render-to-stream (computed-value-value computed-value)
stream)
(write-char #\) stream)
(write-char (if more? #\Space #\)) stream))))
(let* ((class (class-of object))
(table (netfarm-class-computed-slot-table class))
(slots (sort (string-hash-table->alist table)
#'string< :key #'car)))
(unless (null slots)
(write-line "---" stream)
(loop for ((name . slot) . more?) on slots
for computed-values = (closer-mop:slot-value-using-class class object slot)
do (render-to-stream name stream)
(write-char #\Space stream)
(write-computed-value-list computed-values stream))))))
(defun maybe-write-vague-computed-values (vague-object stream)
(let* ((table (vague-object-computed-values vague-object))
(names (sort (alexandria:hash-table-keys table) #'string<)))
(unless (null names)
(write-line "---" stream)
(dolist (name names)
(let ((values (etypecase object
(object (cdr (gethash name table)))
(vague-object (gethash name table)))))
(write-string name stream)
(write-char #\Space stream)
(render-to-stream values stream)
(write-char #\Newline stream))))))
(loop for (name . rest?) on names
for values = (gethash name table)
do (render-to-stream name stream)
(write-char #\Space stream)
(render-to-stream values stream)
when rest?
do (write-char #\Newline stream)))))
(defgeneric render-object-to-stream (object stream emit-computed-values emit-signatures)
(:documentation "Renders the Netfarm object OBJECT to a string.
......@@ -75,6 +98,7 @@ string; but RENDER-OBJECT will emit Netfarm standard format text."))
(setf (gethash "schema" (object-metadata object))
(netfarm-class-name (class-of object)))
(render-hash-table (object-metadata object) stream)
(terpri stream)
(write-line "---" stream)
(render-slots object stream)
(when emit-computed-values
......@@ -91,7 +115,7 @@ string; but RENDER-OBJECT will emit Netfarm standard format text."))
(write-line "---" stream)
(render-hash-table (vague-object-values object) stream)
(when emit-computed-values
(maybe-write-computed-values object stream)))
(maybe-write-vague-computed-values object stream)))
(defun render (object &optional stream)
"Render a Netfarm value to a string, or a stream if one is provided."
......
......@@ -15,8 +15,8 @@
#:map-objects
#:compute-dependencies
#:find-netfarm-class
#:find-netfarm-slot #:map-slots
#:object-slot-unbound
#:find-netfarm-slot #:find-netfarm-computed-slot
#:map-slots #:map-computed-slots
#:class->schema
;; types
#:object #:vague-object #:reference
......@@ -45,8 +45,8 @@
#:*map-schema*
#:find-inbuilt-schema
;; computed values
#:computed-value #:computed-value-cause-object #:computed-value-cause-script
#:computed-value-value
#:computed-value #:computed-value-cause #:computed-value-value
#:add-computed-value
;; inbuilt classes
#:user #:schema
#:user-map #:user-map-antitriples #:user-map-triples #:user-map-delegates
......
......@@ -134,8 +134,7 @@ CL-USER> (defclass foo-class ()
((a :initarg :a)
(b :initarg :b)
(c :initarg :c))
(:metaclass netfarm:netfarm-class)
(:schema-names "foo-class"))
(:metaclass netfarm:netfarm-class))
#<NETFARM:NETFARM-CLASS COMMON-LISP-USER::FOO-CLASS>
CL-USER> (netfarm:render-object (make-instance 'foo-class :a "This is A" :b '("This" "is" 2) :c #(1 2 3 4 5)))
......
......@@ -27,8 +27,8 @@
(netfarm-scripts:setup-interpreter ,script-name
(list ,@arguments))))
(operations (netfarm-scripts:interpreter-instruction-count interpreter))
(time (- (/ (the-cost-of-nothing:benchmark (dotimes (n 10) ,run-script))
10.0)
(time (- (/ (the-cost-of-nothing:benchmark (dotimes (n 15) ,run-script))
15.0)
setup-time)))
(the-cost-of-nothing:write-si-unit (float (/ operations time))
"operations/second"
......@@ -36,7 +36,7 @@
(write-string " (" *trace-output*)
(the-cost-of-nothing:write-si-unit time "seconds" *trace-output*)
(write-string ")" *trace-output*))))))
(define-test object-value-benchmark
:parent benchmark
......@@ -72,7 +72,7 @@
(let ((nowhere (make-broadcast-stream)))
(named-bench render-object (render-object instance :stream nowhere))
(named-bench render (render tree nowhere))
(named-bench render-block (render blob nowhere)))))
(named-bench render-blob (render blob nowhere)))))
(netfarm-scripts:define-script *fib* (1 2)
(:procedure 1)
......@@ -105,5 +105,5 @@
(netfarm-scripts::ensure-discriminator-function)
(announce-bench-group script-machine)
(named-bench/mips "fib(28)" *fib* 28)
(named-bench/mips "loop" *loop* 1000000)
(named-bench/mips "loop" *loop* 2000000)
(named-bench/mips "cons-loop" *cons-loop* '() 1000000))
......@@ -14,19 +14,14 @@
(length 32)
(chars *chars*))
(let ((chars-length (length chars)))
(labels ((random-character (start-p)
(let ((char (char chars (random chars-length))))
;; Don't put space at the start of lines.
(if (and start-p (member char '(#\Tab #\Space #\Newline) :test #'char=))
(random-character start-p)
char))))
(flet ((random-character ()
(char chars (random chars-length))))
(lambda ()
(loop
with str = (make-string length)
for pos below length
do (setf (char str pos)
(random-character (zerop pos)))
finally (return str))))))
(loop with str = (make-string length)
for pos below length
do (setf (char str pos)
(random-character))
finally (return str))))))
(defun random-vector-generator (&key
(length 128))
......
......@@ -2,10 +2,18 @@
(define-test parser-tests)