From rjain at common-lisp.net Wed Nov 4 21:41:34 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 04 Nov 2009 16:41:34 -0500 Subject: [rjain-utils-cvs] CVS formulate/examples Message-ID: Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv29200/examples Modified Files: simple.lisp Log Message: Refactor a bit and get everything working for the basic lazy evaluation and unconditional propagation scenario. --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/04 21:41:34 1.2 @@ -1,5 +1,19 @@ (in-package :formulate-user) +(define-formulated-variable *x* 5 + :formulator-class simple-formulator-source) + +(define-formulated-variable *y* (expt *x* 2)) + +(assert (= *x* 5)) + +(assert (= *y* 25)) + +(setf *x* 2) + +(assert (= *y* 4)) + + (defgeneric area (shape)) (defgeneric perimeter (shape)) @@ -26,4 +40,3 @@ (setf (circle-radius circle) i) (format t "~&A circle with radius ~A has perimeter ~A and area ~A~%" (circle-radius circle) (perimeter circle) (area circle)))) - From rjain at common-lisp.net Wed Nov 4 21:41:35 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 04 Nov 2009 16:41:35 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv29200/src Modified Files: formulate.lisp metaobjects.lisp package.lisp variables.lisp Removed Files: tests.lisp Log Message: Refactor a bit and get everything working for the basic lazy evaluation and unconditional propagation scenario. --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/04 21:41:35 1.2 @@ -1,48 +1,108 @@ (in-package :formulate) +(deftype list-of (elt-type) + 'list) + (defvar *formulating* '() - "Dynamically rebound each time we start computing a formula with the -FORMULATOR CONSed to the front of it.") + "The FORMULATOR, if any, that is being evaluated.") (define-condition set-formulated-location (cell-error) ()) -(defclass standard-formulator-source () - (reverse-dependencies :initform '() :type list :accessor reverse-dependencies) - (value) - (eager-propagation :initform t)) +(defgeneric formulator-value (formulator + &optional unbound-condition cell-name)) -(defclass standard-formulator-sink () - ((eager-recomputation :initform nil))) -(defclass standard-formulator (standard-formulator-source standard-formulator-sink) - ((formula :initarg formula :initform (error "need to specify a formula") - :accessor formulator-formula) - (formula-function :initarg formula-function :initform (error "need to specify a formula-function") :type function - :accessor formulator-formula-function))) +(defmethod formulator-value :around (formulator + &optional unbound-condition cell-name) + (when *formulating* + (note-formula-dependency formulator *formulating*)) + (if (formulator-value-validp formulator) + (call-next-method) + (error unbound-condition :name cell-name))) + +(defgeneric formulator-value-changed (sink source new-value old-value)) + +(defclass simple-formulator-source () + ((dependents :initform '() + :type (list-of formulator-sink) + :accessor formulator-dependents) + (value)) + (:documentation "FORMULATOR-SOURCE implementation that unconditionally + notifies all sinks that depend on it every time its value is changed.")) + +(defmethod initialize-instance :after ((formulator simple-formulator-source) + &key ((formula formula)) ((formula-function formula-function))) + (when formula-function + (setf (slot-value formulator 'value) (funcall formula-function)))) + +(defmethod formulator-value-validp ((source simple-formulator-source)) + (slot-boundp source 'value)) + +(defmethod formulator-invalidate ((source simple-formulator-source)) + (slot-makunbound source 'value)) + +(defmethod formulator-value ((formulator simple-formulator-source) + &optional cond cell) + (slot-value formulator 'value)) + +(defmethod (setf formulator-value) (new-value (formulator simple-formulator-source)) + (let ((old-value (and (formulator-value-validp formulator) + (formulator-value formulator))) + (result (setf (slot-value formulator 'value) new-value))) + (dolist (dependent (formulator-dependents formulator)) + (formulator-source-value-changed dependent formulator new-value old-value)) + result)) -(defun formulate (formulator unbound-condition cell-name) - (if (null formulator) - (error unbound-condition :name cell-name) - (if (slot-boundp formulator 'value) - (slot-value formulator 'value) - (compute-formula formulator)))) - -(defmethod compute-formula ((formulator formulator)) - (note-formula-dependency formulator) - (setf (reverse-dependencies formulator) '()) - (let ((*formulating* (cons formulator *formulating*))) - (setf (slot-value formulator 'value) - (funcall (formulator-formula-function formulator)))) - (when (slot-value formulator 'eager-propagation) - (mapcar (lambda (dependent) (note-dependency-value-changed dependent formulator)) - (slot-value formulator 'reverse-dependencies)))) - -(defmethod note-formula-dependency ((formulator standard-formulator)) - (dolist (surrounding-formulator *formulating*) - (pushnew formulator (reverse-dependencies surrounding-formulator)))) - -(defmethod note-dependency-value-changed ((dependent standard-formulator) (dependency standard-formulator)) - (slot-makunbound dependent 'value) - (when (slot-value dependent 'eager-recomputation) - (compute-formula dependent))) \ No newline at end of file +(defclass formula-formulator-sink () + ((formula :initarg formula + :accessor formulator-formula) + (formula-function :initarg formula-function + :initform (error "need to specify a formula-function") + :type function + :accessor formulator-formula-function)) + (:documentation "FORMULATOR-SINK implementation that recomputes the + formula every time it is asked for a value.")) + +(defmethod formulator-value ((formulator formula-formulator-sink) + &optional cond cell) + (funcall (formulator-formula-function formulator))) + +(defmethod formulator-value-validp ((formulator formula-formulator-sink)) + (slot-boundp formulator 'formula)) + +(defclass lazy-formula-formulator-sink (formula-formulator-sink) + ((source :initarg source + :initform (make-instance 'simple-formulator-source) + :accessor formulator-source + :documentation "FORMULATOR-SOURCE that contains the cached + value and propagates changes to sinks that refer to this + formulator's parent cell.")) + (:documentation "FORMULATOR-SINK implementation that lazily recomputes + and caches the formula's value.")) + +(defmethod formulator-dependents ((formulator lazy-formula-formulator-sink)) + (formulator-dependents (formulator-source formulator))) + +(defmethod (setf formulator-dependents) (new-value (formulator lazy-formula-formulator-sink)) + (setf (formulator-dependents (formulator-source formulator)) new-value)) + +(defmethod formulator-value ((formulator lazy-formula-formulator-sink) + &optional cond cell) + (let ((source (formulator-source formulator))) + (if (formulator-value-validpxo source) + (let ((*formulating* nil)) + (formulator-value source cond cell)) + (let ((*formulating* formulator)) + ;; TODO: remove dependencies when dependencies change + (setf (formulator-value source) (call-next-method)))))) + +(defmethod formulator-invalidate ((formulator lazy-formula-formulator-sink)) + (formulator-invalidate (formulator-source formulator))) + +(defmethod note-formula-dependency (source sink) + (pushnew sink (formulator-dependents source))) + +(defmethod formulator-source-value-changed + ((sink lazy-formula-formulator-sink) source new-value old-value) + (formulator-invalidate sink)) --- /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2009/11/04 21:41:35 1.2 @@ -7,62 +7,75 @@ t) (defclass formulated-slot-definition (standard-slot-definition) - ((formulator-class :initform 'standard-formulator :initarg formulator-class :accessor formulator-class) - (formulator-options :initform '() :initarg formulator-options :accessor formulator-options))) + ((formulator-class :initarg formulator-class + :accessor formulator-class) + (formulator-options :initform '() + :initarg formulator-options + :accessor formulator-options))) (defclass formulated-direct-slot-definition (formulated-slot-definition standard-direct-slot-definition) ()) +(defmethod initialize-instance :after ((instance formulated-direct-slot-definition) + &key ((formula-p formula-p))) + "default formulator-class based on whether this is a formula or not" + (unless (slot-boundp instance 'formulator-class) + (setf (slot-value instance 'formulator-class) + (if formula-p + 'lazy-formula-formulator-sink + 'simple-formulator-source)))) + (defmethod slot-definition-initfunction ((slotd formulated-direct-slot-definition)) (lambda () (apply 'make-instance (formulator-class slotd) 'formula (slot-definition-initform slotd) 'formula-function (call-next-method) (formulator-options slotd)))) -(defmethod initialize-instance :after ((instance formulated-slot-definition) &key ((formula-p formula-p) t)) - (declare (ignore formula-p)) - ;; FORMULA-P is already reflected in the class chosen by DIRECT-SLOT-DEFINITION-CLASS - ) - -(defmethod direct-slot-definition-class ((class formulated-class) - &key ((formula-p formula-p) nil) &allow-other-keys) - (if formula-p - 'formulated-direct-slot-definition - 'formulated-source-)) +(defmethod direct-slot-definition-class ((class formulated-class) &key &allow-other-keys) + ;; formula-p only indicates whether this is a formula sink as well as + ;; a source. + 'formulated-direct-slot-definition) (defclass formulated-effective-slot-definition (formulated-slot-definition standard-effective-slot-definition) ()) -(defvar *computing-formulated-eslotd* nil) - (defmethod effective-slot-definition-class ((class formulated-class) &key &allow-other-keys) - (if *computing-formulated-eslotd* - 'formulated-effective-slot-definition - (call-next-method))) + ;; formula-p only indicates whether this is a formula sink as well as + ;; a source. + 'formulated-effective-slot-definition) (defmethod compute-effective-slot-definition ((class formulated-class) slot-name dslotds) - (declare (type list dslotds)) - (let ((*computing-formulated-eslotd* - (find-if (lambda (slotd) (typep slotd 'formulated-direct-slot-definition)) dslotds))) - (call-next-method))) + (let ((eslotd (call-next-method)) + (most-specific-fdslotd + (find-if + (lambda (slotd) + (typep slotd 'formulated-direct-slot-definition)) + dslotds))) + (setf (slot-value eslotd 'formulator-class) + (formulator-class most-specific-fdslotd)) + eslotd)) (defvar *me*) -(defmethod slot-value-using-class ((class formulated-class) object (slotd formulated-effective-slot-definition)) - (let ((*me* object)) - (formulate (call-next-method) 'unbound-slot (slot-definition-name slotd)))) +(defvar *get-slot-formulator* nil) -(define-condition set-formulated-slot (set-formulated-location) - ()) - -(defmethod (setf slot-value-using-class) (new-value - (class formulated-class) object (slotd formulated-effective-slot-definition)) - (declare (ignore new-value class)) - (call-next-method) - #+nil ; this doesn't seem to work... - (if (typep object 'formulator) +(defmethod slot-value-using-class :around + (class object (slotd formulated-effective-slot-definition)) + (if *get-slot-formulator* (call-next-method) - (error 'set-formulated-slot :name (slot-definition-name slotd)))) + (let ((*me* object)) + (formulator-value (call-next-method) 'unbound-slot (slot-definition-name slotd))))) + +(defmethod slot-formulator-using-class (class object (slotd formulated-effective-slot-definition)) + (let ((*get-slot-formulator* t)) + (slot-value-using-class class object slotd))) + +(defmethod (setf slot-value-using-class) :around + (new-value + class object (slotd formulated-effective-slot-definition)) + (if (slot-boundp-using-class class object slotd) + (setf (formulator-value (slot-formulator-using-class class object slotd)) new-value) + (call-next-method))) (declaim (inline my)) (defun my (slot) --- /project/rjain-utils/cvsroot/formulate/src/package.lisp 2007/11/02 20:45:35 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/04 21:41:35 1.2 @@ -1,11 +1,15 @@ (defpackage :formulate (:export #:formulator - #:standard-formulator + #:simple-formulator-source + #:formula-formulator-sink + #:lazy-formula-formulator-sink #:formulated-class #:my #:formula-p + #:formulator-class + #:formulator-options #:define-formulated-variable) - (:use :cl :mop)) + (:use :cl #.(first '(#+sbcl :sb-mop :mop)))) (defpackage :formulate-user (:use :cl :formulate)) \ No newline at end of file --- /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/04 21:41:35 1.2 @@ -1,25 +1,22 @@ (in-package :formulate) (defmacro define-formulated-variable (name formula - &key declare + &key declare documentation - (formulator-class 'standard-formulator) + (formulator-class 'lazy-formula-formulator-sink) formulator-options) `(progn (define-symbol-macro ,name (formulate-variable ',name)) (setf (documentation ',name 'variable) ,documentation) - (setf (get name 'formulator) + (setf (symbol-value ',name) (make-instance ',formulator-class 'formula ',formula 'formula-function (lambda () (declare , at declare) ,formula) - , at formulator-options)))) + , at formulator-options)) + ',name)) (defun formulate-variable (name) - (formulate (get name 'formulator) 'unbound-variable name)) - -(define-condition set-formuated-variable (set-formulated-location) - ()) + (formulator-value (symbol-value name) 'unbound-variable name)) (defun (setf formulate-variable) (new-value name) - (declare (ignore new-value)) - (error 'set-formulated-variable :name name)) + (setf (formulator-value (symbol-value name)) new-value)) From rjain at common-lisp.net Thu Nov 5 21:27:45 2009 From: rjain at common-lisp.net (rjain) Date: Thu, 05 Nov 2009 16:27:45 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv31628/src Modified Files: formulate.lisp Log Message: fix typo... --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/05 21:27:45 1.3 @@ -90,7 +90,7 @@ (defmethod formulator-value ((formulator lazy-formula-formulator-sink) &optional cond cell) (let ((source (formulator-source formulator))) - (if (formulator-value-validpxo source) + (if (formulator-value-validp source) (let ((*formulating* nil)) (formulator-value source cond cell)) (let ((*formulating* formulator)) From rjain at common-lisp.net Wed Nov 11 08:52:11 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 03:52:11 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9061/src Modified Files: formulate.lisp Log Message: minor renaming and cleanups --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/05 21:27:45 1.3 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/11 08:52:10 1.4 @@ -3,16 +3,16 @@ (deftype list-of (elt-type) 'list) +;;; +;;; *** GENERAL DEFINITIONS *** +;;; + (defvar *formulating* '() "The FORMULATOR, if any, that is being evaluated.") (define-condition set-formulated-location (cell-error) ()) -(defgeneric formulator-value (formulator - &optional unbound-condition cell-name)) - - (defmethod formulator-value :around (formulator &optional unbound-condition cell-name) (when *formulating* @@ -21,7 +21,9 @@ (call-next-method) (error unbound-condition :name cell-name))) -(defgeneric formulator-value-changed (sink source new-value old-value)) +;;; +;;; *** SIMPLE FORMULATOR SOURCE +;;; (defclass simple-formulator-source () ((dependents :initform '() @@ -51,9 +53,13 @@ (formulator-value formulator))) (result (setf (slot-value formulator 'value) new-value))) (dolist (dependent (formulator-dependents formulator)) - (formulator-source-value-changed dependent formulator new-value old-value)) + (formulator-value-changed dependent formulator new-value old-value)) result)) +;;; +;;; FORMULA FORMULATOR SINK +;;; + (defclass formula-formulator-sink () ((formula :initarg formula :accessor formulator-formula) @@ -71,6 +77,10 @@ (defmethod formulator-value-validp ((formulator formula-formulator-sink)) (slot-boundp formulator 'formula)) +;;; +;;; *** LAZY FORMULATOR SINK +;;; + (defclass lazy-formula-formulator-sink (formula-formulator-sink) ((source :initarg source :initform (make-instance 'simple-formulator-source) @@ -103,6 +113,6 @@ (defmethod note-formula-dependency (source sink) (pushnew sink (formulator-dependents source))) -(defmethod formulator-source-value-changed +(defmethod formulator-value-changed ((sink lazy-formula-formulator-sink) source new-value old-value) (formulator-invalidate sink)) From rjain at common-lisp.net Wed Nov 11 08:53:07 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 03:53:07 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9184/src Modified Files: package.lisp Log Message: added *me* to exports added package for metaprogramming, but can't eval it right away, so commented it out for now --- /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/11 08:53:07 1.3 @@ -5,6 +5,7 @@ #:lazy-formula-formulator-sink #:formulated-class #:my + #:*me* #:formula-p #:formulator-class #:formulator-options @@ -12,4 +13,21 @@ (:use :cl #.(first '(#+sbcl :sb-mop :mop)))) (defpackage :formulate-user - (:use :cl :formulate)) \ No newline at end of file + (:use :cl :formulate)) + +#+nil +(defpackage :formulate-meta + (:export . #1=(#:*formulating* + #:formulator-value + #:formulator-formula + #:formulator-formula-function + #:formulator-value-validp + #:formulator-invalidate + #:simple-formulator-source + #:formula-formulator-sink + #:lazy-formula-formulator-sink + #:formulated-slot-definition + #:formulated-direct-slot-definition + #:formulated-effective-slot-definition + #:slot-formulator-using-class)) + (:shadowing-import-from :formulate . #1#)) From rjain at common-lisp.net Wed Nov 11 08:54:08 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 03:54:08 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9275/src Modified Files: variables.lisp Log Message: default formulator class for variables in the same way we do for slots --- /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/11 08:54:08 1.3 @@ -3,13 +3,17 @@ (defmacro define-formulated-variable (name formula &key declare documentation - (formulator-class 'lazy-formula-formulator-sink) + (formula-p t) + formulator-class formulator-options) `(progn (define-symbol-macro ,name (formulate-variable ',name)) (setf (documentation ',name 'variable) ,documentation) (setf (symbol-value ',name) - (make-instance ',formulator-class + (make-instance ',(or formulator-class + (if formula-p + 'lazy-formula-formulator-sink + 'simple-formulator-source)) 'formula ',formula 'formula-function (lambda () (declare , at declare) ,formula) , at formulator-options)) From rjain at common-lisp.net Wed Nov 11 08:56:27 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 03:56:27 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9463/src Modified Files: clim-ui.lisp Log Message: get variables working get class instantiation and instance display and slot setting working class definition doesn't work in mcclim due to accepting of deep structure being hairy clicking on slots to use an instance's slot value does not work, either -- sends DREI off a cliff --- /project/rjain-utils/cvsroot/formulate/src/clim-ui.lisp 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui.lisp 2009/11/11 08:56:26 1.2 @@ -1,27 +1,75 @@ (defpackage :formulate.clim-ui (:export #:formulate) - (:use :clim-lisp :formulate :clim)) + (:use :clim-lisp :formulate :clim #.(first (list #+sbcl :sb-mop :mop)))) (in-package :formulate.clim-ui) (define-application-frame formulate () - () + ((monitored-values :initform (make-array 5 :fill-pointer 0 :adjustable t) + :accessor monitored-values)) (:panes (interactor :interactor - :scroll-bars t)) + :scroll-bars t) + (monitor :application + :scroll-bars t + :incremental-redisplay t + :display-function 'display-monitor + :display-time :command-loop)) (:pointer-documentation t) (:layouts (default - interactor))) + monitor + interactor))) -(define-formulate-command (com-define-formulated-variable :name "Define Formulated Variable") - ((name 'symbol) (formula 'expression) - (declarations 'expression :default '()) - (documentation '(or string null) :default nil)) - (funcall (compile nil (lambda () `(define-formulated-variable ,name ,formula - :declare ,declarations :documentation ,documentation))))) - -(define-formulate-command (com-define-formulated-class :name "Define Formulated Class") - ((name 'symbol) (superclasses '(sequence class) :default '()) (slots '(sequence slot-specification))) +(defun display-monitor (*application-frame* *standard-output*) + (updating-output (t :unique-id (monitored-values *application-frame*)) + (map nil (lambda (item) (display-monitored-value item)) + (monitored-values *application-frame*)))) + +(defmethod display-monitored-value (item) + (updating-output (t :unique-id item) + (call-next-method))) + +(defmethod frame-standard-output ((frame formulate)) + (get-frame-pane frame 'interactor)) + + +;;; +;;; VARIABLES +;;; + +(define-formulate-command (com-define-formulated-variable :name "Define Variable") + ((name 'symbol :prompt "Name") + (formula-p 'boolean :prompt "Formula?") + (formula 'expression :prompt (if formula-p "Formula" "Initial value")) + (monitor-p 'boolean :default t :prompt "Show in monitor pane?") + (declarations 'expression :default '() :prompt "Declarations") + (documentation '(or string null) :default nil :prompt "Documentation")) + (eval `(define-formulated-variable ,name ,formula + :formula-p ,formula-p + :declare ,declarations :documentation ,documentation)) + (when monitor-p + (let ((*standard-output* (get-frame-pane *application-frame* 'monitor))) + (vector-push-extend name (monitored-values *application-frame*))))) + +(defmethod display-monitored-value ((name symbol)) + (let ((value (eval name))) + (fresh-line) + (present name 'symbol) + (write-string " = ") + (present value (presentation-type-of value)))) + +(define-formulate-command (com-set-variable :name "Set Variable") + ((name 'symbol) (value 'expression)) + (eval `(setf ,name ,value))) + +;;; +;;; CLASSES +;;; + +(define-formulate-command (com-define-formulated-class :name "Define Class") + ((name 'symbol :prompt "Name") + (superclasses '(sequence symbol) :default () :prompt "Superclasses") + (slots '(sequence slot-specification) :prompt "Slots")) (eval `(defclass ,name ,(coerce superclasses 'list) (,@(coerce slots 'list)) (:metaclass formulated-class)))) @@ -29,11 +77,78 @@ (define-presentation-type slot-specification () :inherit-from 'expression) -(define-presentation-method accept ((type slot-specification) stream view &key default default-type) +(define-presentation-method accept ((type slot-specification) stream view + &key default) (let* ((name (if default (accept 'symbol :prompt "Name" :default (first default)) - (accept 'symbol :prompt "Name"))) - (formulated-p (accept 'boolean :prompt "Formulated?" - :default (getf default 'formulated-p t) :default-type 'boolean)) - (initform (accept 'expression :prompt (if formulated-p "Formula" "Initial value")))) - `(,name formulated-p ,formulated-p :initform ,initform))) + (accept 'symbol :prompt "Name"))) + (formula-p (accept 'boolean + :prompt "Formula?" + :default (getf default 'formula-p t) + :default-type 'boolean)) + (initform (accept 'expression :prompt (if formula-p "Formula" "Initial value")))) + `(,name formula-p ,formula-p :initform ,initform))) + +(define-formulate-command (com-create-instance :name "Create Instance") + ((class 'symbol)) + (vector-push-extend (make-instance class) + (monitored-values *application-frame*))) + +(defmethod display-monitored-value ((object standard-object)) + (fresh-line) + (present object 'formulated-object)) + +(define-presentation-type formulated-object () + :inherit-from t) + +(define-presentation-method presentation-typep (object (type formulated-object)) + (some (lambda (super) (typep super 'formulated-class)) + (class-precedence-list object))) + +(define-presentation-method present (object (type formulated-object) stream view + &key acceptably for-context-type) + (prin1 (class-name (class-of object))) + (fresh-line) + (formatting-table (stream) + (dolist (slot (class-slots (class-of object))) + (present `(slot-value ,object ,(slot-definition-name slot)) + 'formulated-slot + :stream stream :view view + :acceptably acceptably :for-context-type for-context-type)))) + +(define-presentation-type formulated-slot () + ;; 3 element list: (slot-value ) + :inherit-from '(sequence t)) + +(define-presentation-method presentation-typep ((expression cons) (type formulated-slot)) + (and (= 3 (length expression)) + (destructuring-bind (slot-value object slot) expression + (and (eq 'slot-value slot-value) + (typep slot 'symbol) + (some (lambda (super) (typep super 'formulated-class)) + (class-precedence-list object)))))) + +(define-presentation-method present (expression (type formulated-slot) stream view + &key acceptably for-context-type) + (when (and (consp (first expression)) + (eq 'quote (first (first expression)))) + (setf expression (second (first expression)))) + (destructuring-bind (s-v object slot) expression + (formatting-row (stream) + (formatting-cell (stream) + (present slot 'symbol + :stream stream :view view :sensitive nil)) + (formatting-cell (stream) + (let ((slot-value (slot-value object slot))) + (present slot-value `(and ,(presentation-type-of slot-value) + formulated-value) + :stream stream :view view :sensitive t)))))) + +(define-formulate-command (com-set-slot-value :name "Set Slot Value") + ((object.slot 'formulated-slot :prompt "Slot") + (new-value 'expression :prompt "New value")) + ;; not sure why object.slot has other crap around it, but hacking + ;; around it. + (destructuring-bind (s-v object slot) (second (first object.slot)) + (setf (slot-value object slot) (eval new-value)))) + From rjain at common-lisp.net Wed Nov 11 08:57:22 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 03:57:22 -0500 Subject: [rjain-utils-cvs] CVS formulate/examples Message-ID: Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv9595/examples Modified Files: simple.lisp Log Message: fix perimeter formula and provide default side lengths --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/04 21:41:34 1.2 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/11 08:57:21 1.3 @@ -1,7 +1,8 @@ (in-package :formulate-user) +;; default is for variables to be formulas (define-formulated-variable *x* 5 - :formulator-class simple-formulator-source) + :formula-p nil) (define-formulated-variable *y* (expt *x* 2)) @@ -17,14 +18,15 @@ (defgeneric area (shape)) (defgeneric perimeter (shape)) +;; default is for slots to not be formulas --- is this inconsistency good or bad? (defclass square () - ((side :initarg side :accessor square-side) - (perimeter formula-p t :initform (* (my 'side) 2) :reader perimeter) + ((side :initarg side :initform 0 :accessor square-side) + (perimeter formula-p t :initform (* (my 'side) 4) :reader perimeter) (area formula-p t :initform (expt (my 'side) 2) :reader area)) (:metaclass formulated-class)) (defclass circle () - ((radius :initarg radius :accessor circle-radius) + ((radius :initform 0 :initarg radius :accessor circle-radius) (perimeter formula-p t :initform (* (my 'radius) 2 pi) :reader perimeter) (area formula-p t :initform (* (expt (my 'radius) 2) pi) :reader area)) (:metaclass formulated-class)) From rjain at common-lisp.net Wed Nov 11 08:58:02 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 03:58:02 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv9682/src Added Files: protocol.lisp Log Message: add definitions for formulator protocol and subprotocols --- /project/rjain-utils/cvsroot/formulate/src/protocol.lisp 2009/11/11 08:58:02 NONE +++ /project/rjain-utils/cvsroot/formulate/src/protocol.lisp 2009/11/11 08:58:02 1.1 (defprotocol formulator ()) (defprotocol formulator-source (formulator)) (defprotocol formulator-sink (formulator)) (defprotocol formula-formulator (formulator)) (defgeneric formulator-value (formulator &optional unbound-condition cell-name)) (defsignature formulator-value (formulator-source)) (defgeneric (setf formulator-value) (new-value formulator)) ;; separate formulator-root that allows setf? (defsignature (setf formulator-value) (t formulator-source)) (defgeneric formulator-value-validp (formulator)) (defsignature formulator-value-validp (formulator-source)) (defgeneric formulator-invalidate (formulator)) (defsignature formulator-invalidate (formulator-source)) (defgeneric formulator-dependents (formulator)) (defsignature formulator-dependents (formulator-source)) (defgeneric formulator-value-changed (sink source new-value old-value)) (defsignature formulator-value-changed (formulator-sink formulator-source t t)) (defgeneric formulator-formula (formulator)) ; change to formulator-formula-source? (defsignature formulator-formula (formula-formulator)) ; change to formulator-formula-source? (defgeneric formulator-formula-function (formulator)) ; change to formulator-function? (defsignature formulator-formula-function (formula-formulator)) ; change to formulator-function? (defgeneric (setf formulator-value) (new-formula formulator)) (defsignature (setf formulator-value) (function formula-formulator)) ; separate dynamic-formula-formulator subprotocol? From rjain at common-lisp.net Wed Nov 11 20:32:53 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 11 Nov 2009 15:32:53 -0500 Subject: [rjain-utils-cvs] CVS formulate/src/clim-ui Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv15937/src/clim-ui Log Message: Directory /project/rjain-utils/cvsroot/formulate/src/clim-ui added to the repository From rjain at common-lisp.net Thu Nov 19 00:41:58 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 18 Nov 2009 19:41:58 -0500 Subject: [rjain-utils-cvs] CVS formulate/examples Message-ID: Update of /project/rjain-utils/cvsroot/formulate/examples In directory cl-net:/tmp/cvs-serv27901/examples Modified Files: simple.lisp Log Message: another formulated class for more interesting testing --- /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/11 08:57:21 1.3 +++ /project/rjain-utils/cvsroot/formulate/examples/simple.lisp 2009/11/19 00:41:57 1.4 @@ -25,6 +25,20 @@ (area formula-p t :initform (expt (my 'side) 2) :reader area)) (:metaclass formulated-class)) +(defclass polygon () + ((side :initarg side :initform 0 :accessor polygon-side) + (num-sides :initarg num-sides :initform 1 :accessor polygon-num-sides) + (perimeter formula-p t + :initform (* (my 'side) (my 'num-sides)) + :reader perimeter) + (area formula-p t + :initform (* 1/4 + (my 'num-sides) + (expt (my 'side) 2) + (/ (tan (/ pi (my 'num-sides))))) + :reader area)) + (:metaclass formulated-class)) + (defclass circle () ((radius :initform 0 :initarg radius :accessor circle-radius) (perimeter formula-p t :initform (* (my 'radius) 2 pi) :reader perimeter) From rjain at common-lisp.net Thu Nov 19 00:44:14 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 18 Nov 2009 19:44:14 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv28087/src Modified Files: formulate.lisp metaobjects.lisp package.lisp variables.lisp Log Message: add dynamic-formulators: formua-formulators which allow changing of the formula at run time unify the procedure for accessing the formuator of a variable or slot --- /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/11 08:52:10 1.4 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.lisp 2009/11/19 00:44:14 1.5 @@ -7,6 +7,8 @@ ;;; *** GENERAL DEFINITIONS *** ;;; +(defvar *get-formulator* nil) + (defvar *formulating* '() "The FORMULATOR, if any, that is being evaluated.") @@ -116,3 +118,15 @@ (defmethod formulator-value-changed ((sink lazy-formula-formulator-sink) source new-value old-value) (formulator-invalidate sink)) + +;;; +;;; DYNAMIC-FORMULATOR +;;; + +(defclass dynamic-formulator (lazy-formula-formulator-sink) + ()) + +(defmethod (setf formulator-value) (new-value (formulator dynamic-formulator)) + (setf (formulator-formula formulator) new-value + (formulator-formula-function formulator) (compile nil `(lambda () ,new-value))) + (formulator-invalidate formulator)) --- /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2009/11/04 21:41:35 1.2 +++ /project/rjain-utils/cvsroot/formulate/src/metaobjects.lisp 2009/11/19 00:44:14 1.3 @@ -57,17 +57,15 @@ (defvar *me*) -(defvar *get-slot-formulator* nil) - (defmethod slot-value-using-class :around (class object (slotd formulated-effective-slot-definition)) - (if *get-slot-formulator* + (if *get-formulator* (call-next-method) (let ((*me* object)) (formulator-value (call-next-method) 'unbound-slot (slot-definition-name slotd))))) (defmethod slot-formulator-using-class (class object (slotd formulated-effective-slot-definition)) - (let ((*get-slot-formulator* t)) + (let ((*get-formulator* t)) (slot-value-using-class class object slotd))) (defmethod (setf slot-value-using-class) :around @@ -80,3 +78,7 @@ (declaim (inline my)) (defun my (slot) (slot-value *me* slot)) + +(defun slot-formulator (object slot-name) + (let ((*get-formulator* t)) + (slot-value object slot-name))) \ No newline at end of file --- /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/11 08:53:07 1.3 +++ /project/rjain-utils/cvsroot/formulate/src/package.lisp 2009/11/19 00:44:14 1.4 @@ -29,5 +29,6 @@ #:formulated-slot-definition #:formulated-direct-slot-definition #:formulated-effective-slot-definition + #:slot-formulator #:slot-formulator-using-class)) (:shadowing-import-from :formulate . #1#)) --- /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/11 08:54:08 1.3 +++ /project/rjain-utils/cvsroot/formulate/src/variables.lisp 2009/11/19 00:44:14 1.4 @@ -12,7 +12,7 @@ (setf (symbol-value ',name) (make-instance ',(or formulator-class (if formula-p - 'lazy-formula-formulator-sink + 'dynamic-formulator 'simple-formulator-source)) 'formula ',formula 'formula-function (lambda () (declare , at declare) ,formula) @@ -20,7 +20,9 @@ ',name)) (defun formulate-variable (name) - (formulator-value (symbol-value name) 'unbound-variable name)) + (if *get-formulator* + (symbol-value name) + (formulator-value (symbol-value name) 'unbound-variable name))) (defun (setf formulate-variable) (new-value name) (setf (formulator-value (symbol-value name)) new-value)) From rjain at common-lisp.net Thu Nov 19 01:17:18 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 18 Nov 2009 20:17:18 -0500 Subject: [rjain-utils-cvs] CVS formulate/src Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src In directory cl-net:/tmp/cvs-serv2325/src Modified Files: formulate.asd Removed Files: clim-ui.lisp Log Message: move the CLIM UI to a separate directory add lots of functionality slot setting now works --- /project/rjain-utils/cvsroot/formulate/src/formulate.asd 2007/11/02 20:45:39 1.1.1.1 +++ /project/rjain-utils/cvsroot/formulate/src/formulate.asd 2009/11/19 01:17:18 1.2 @@ -4,8 +4,3 @@ (:file "formulate" :depends-on ("package")) (:file "variables" :depends-on ("package" "formulate")) (:file "metaobjects" :depends-on ("package" "formulate")))) - -(asdf:defsystem :formulate.clim-ui - :components - ((:file "clim-ui")) - :depends-on (:formulate :clim)) \ No newline at end of file From rjain at common-lisp.net Thu Nov 19 01:17:18 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 18 Nov 2009 20:17:18 -0500 Subject: [rjain-utils-cvs] CVS formulate/src/clim-ui Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv2325/src/clim-ui Added Files: application.lisp formulate.clim-ui.asd objects.lisp package.lisp variables.lisp Log Message: move the CLIM UI to a separate directory add lots of functionality slot setting now works --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/19 01:17:18 1.1 (in-package :formulate.clim-ui) (define-application-frame formulate () ((monitored-values :initform (make-array 5 :fill-pointer 0 :adjustable t) :accessor monitored-values)) (:panes (interactor :interactor :scroll-bars t) (monitor :application :scroll-bars t :incremental-redisplay t :display-function 'display-monitor :display-time :command-loop)) (:pointer-documentation t) (:layouts (default monitor interactor))) (defun display-monitor (*application-frame* *standard-output*) (updating-output (t :unique-id (monitored-values *application-frame*)) (map nil (lambda (item) (display-monitored-value item)) (monitored-values *application-frame*)))) (defmethod display-monitored-value (item) (updating-output (t :unique-id item) (call-next-method))) (defvar *error-formulator* nil) (defmacro display-formula-value (location) `(catch 'formula-value-fail (handler-bind ((error #'(lambda (error) (display-formula-error error formulate::*formulating*) (throw 'formula-value-fail nil)))) (let ((error-source-p (eql *error-formulator* (let ((formulate::*get-formulator* t)) ,location))) (value ,location)) (when error-source-p (with-text-face (t :bold) (with-drawing-options (t :ink +red+) (write-string ">>>")))) (present value (presentation-type-of value)) (when error-source-p (with-text-face (t :bold) (with-drawing-options (t :ink +red+) (write-string "<<<")))))))) (defmethod frame-standard-output ((frame formulate)) (get-frame-pane frame 'interactor)) (define-presentation-type formula-error () :inherit-from t) (defstruct formula-error error formulator) (define-presentation-method present (error (type formula-error) stream (view textual-view) &key) (print-unreadable-object ((formula-error-error error) stream :type t))) (defun display-formula-error (error formulator) (with-output-as-presentation (t (make-formula-error :error error :formulator formulator) 'formula-error) (with-text-face (t :italic) (with-drawing-options (t :ink +red+) (write-char #\!) (prin1 (class-name (class-of error))) (write-char #\!))))) (define-formulate-command com-describe-error ((err 'formula-error :gesture :select)) (setf *error-formulator* (formula-error-formulator err)) (present (formula-error-error err) t) (format t "~&while computing ~A" (formulate::formulator-formula (formula-error-formulator err)))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/formulate.clim-ui.asd 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/formulate.clim-ui.asd 2009/11/19 01:17:18 1.1 (asdf:defsystem :formulate.clim-ui :components ((:file "package") (:file "application" :depends-on ("package")) (:file "variables" :depends-on ("package" "application")) (:file "objects" :depends-on ("package" "application"))) :depends-on (:formulate :clim)) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/19 01:17:18 1.1 (in-package :formulate.clim-ui) (define-formulate-command (com-define-formulated-class :name "Define Class") ((name 'symbol :prompt "Name") (superclasses '(sequence symbol) :default () :prompt "Superclasses") (slots '(sequence slot-specification) :prompt "Slots")) (eval `(defclass ,name ,(coerce superclasses 'list) (,@(coerce slots 'list)) (:metaclass formulated-class)))) (define-presentation-type slot-specification () :inherit-from 'expression) (define-presentation-method accept ((type slot-specification) stream view &key default) (let* ((name (if default (accept 'symbol :prompt "Name" :default (first default)) (accept 'symbol :prompt "Name"))) (formula-p (accept 'boolean :prompt "Formula?" :default (getf default 'formula-p t) :default-type 'boolean)) (initform (accept 'expression :prompt (if formula-p "Formula" "Initial value")))) `(,name formula-p ,formula-p :initform ,initform))) (define-formulate-command (com-create-instance :name "Create Instance") ((class '(or class symbol) :prompt "Class")) (vector-push-extend (make-instance class) (monitored-values *application-frame*))) (defmethod display-monitored-value ((object standard-object)) (fresh-line) (present object 'formulated-object)) (define-presentation-type formulated-object () :inherit-from t) (define-presentation-type formulated-slot () ;; 3 element list: (slot-value ) :inherit-from t) (define-presentation-method presentation-typep (object (type formulated-object)) (some (lambda (super) (typep super 'formulated-class)) (class-precedence-list object))) (defmethod display-slot-as-row (object slot stream view) (formatting-row (stream) (formatting-cell (stream) (with-text-face (stream :italic) (prin1 (slot-definition-name slot)) (write-char #\: stream))) (formatting-cell (stream) (display-formula-value (slot-value object (slot-definition-name slot)))))) (define-presentation-method present (object (type formulated-object) stream view &key) (with-output-as-presentation (stream object 'formulated-object) (with-output-as-presentation (stream (class-of object) 'class) (with-text-face (stream :bold) (prin1 (class-name (class-of object)) stream))) (fresh-line stream) (formatting-table (stream) (dolist (slot (class-slots (class-of object))) (with-output-as-presentation (stream `(slot-value ,object ',(slot-definition-name slot)) 'formulated-slot) (display-slot-as-row object slot stream view)))))) (define-presentation-translator slot-accessor (formulated-slot form formulate) (object) (format t "translating slot to expression") (values object 'expression t)) (define-formulate-command (com-set-slot-value :name "Set Slot Value") ((expression 'formulated-slot :prompt "Slot") (new-value 'form :prompt "New value")) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (setf (slot-value object slot) (eval new-value)))) (define-presentation-to-command-translator set-slot-value (formulated-slot com-set-slot-value formulate :gesture :select) (object) (list object (accept 'form :prompt (format nil "Set Slot Value (Slot) ~a (New value)" object)))) (define-formulate-command (com-describe-slot :name "Describe Slot") ((expression 'formulated-slot :prompt "Slot" :gesture :describe)) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (let ((formulator (formulate::slot-formulator object slot))) (format t "Slot ~A of ~A is computed by ~A~%using formula ~A" slot object formulator (formulate::formulator-formula formulator))))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/package.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/package.lisp 2009/11/19 01:17:18 1.1 (defpackage :formulate.clim-ui (:export #:formulate) (:use :clim-lisp :formulate :clim #.(first (list #+sbcl :sb-mop :mop)))) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/19 01:17:18 NONE +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/19 01:17:18 1.1 (in-package :formulate.clim-ui) (define-formulate-command (com-define-formulated-variable :name "Define Variable") ((name 'symbol :prompt "Name") (formula-p 'boolean :prompt "Formula?") (formula 'expression :prompt (if formula-p "Formula" "Initial value")) (monitor-p 'boolean :default t :prompt "Show in monitor pane?") (declarations 'expression :default '() :prompt "Declarations") (documentation '(or string null) :default nil :prompt "Documentation")) (eval `(define-formulated-variable ,name ,formula :formula-p ,formula-p :declare ,declarations :documentation ,documentation)) (when monitor-p (let ((*standard-output* (get-frame-pane *application-frame* 'monitor))) (vector-push-extend name (monitored-values *application-frame*))))) (defmethod display-monitored-value ((name symbol)) (fresh-line) (with-text-face (t :bold) (present name 'symbol)) (write-string " = ") (display-formula-value (eval name))) (define-formulate-command (com-set-variable :name "Set Variable") ((name 'symbol) (new-value 'form)) (eval `(setf ,name ',value))) (define-presentation-to-command-translator set-variable (symbol com-set-variable formulate :gesture :select) (name) (list name (let ((stream t)) (format stream " Set Variable (Name) ~a (New value) " name) (accept 'form :prompt nil :stream stream)))) (define-formulate-command (com-describe-variable :name "Describe Variable") ((name 'symbol :prompt "Name" :gesture :describe)) (let ((formulator (let ((formulate::*get-formulator* t)) (eval name)))) (format t "Variable ~A is computed by ~A~%using formula ~A" name formulator (formulate::formulator-formula formulator)))) From rjain at common-lisp.net Tue Nov 24 10:06:47 2009 From: rjain at common-lisp.net (rjain) Date: Tue, 24 Nov 2009 05:06:47 -0500 Subject: [rjain-utils-cvs] CVS formulate/src/clim-ui Message-ID: Update of /project/rjain-utils/cvsroot/formulate/src/clim-ui In directory cl-net:/tmp/cvs-serv899/src/clim-ui Modified Files: application.lisp objects.lisp variables.lisp Log Message: add remove from monitor command simplify and fix other commands --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/application.lisp 2009/11/24 10:06:47 1.2 @@ -21,10 +21,13 @@ (map nil (lambda (item) (display-monitored-value item)) (monitored-values *application-frame*)))) -(defmethod display-monitored-value (item) +(defmethod display-monitored-value :around (item) (updating-output (t :unique-id item) (call-next-method))) +(defun remove-from-monitor (value *application-frame*) + (delete value (monitored-values *application-frame*))) + (defvar *error-formulator* nil) (defmacro display-formula-value (location) --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/objects.lisp 2009/11/24 10:06:47 1.2 @@ -28,13 +28,13 @@ (vector-push-extend (make-instance class) (monitored-values *application-frame*))) +(define-presentation-type formulated-object () + :inherit-from t) + (defmethod display-monitored-value ((object standard-object)) (fresh-line) (present object 'formulated-object)) -(define-presentation-type formulated-object () - :inherit-from t) - (define-presentation-type formulated-slot () ;; 3 element list: (slot-value ) :inherit-from t) @@ -71,20 +71,17 @@ (format t "translating slot to expression") (values object 'expression t)) +(define-formulate-command (com-remove-object :name "Remove Object From Monitor") + ((object 'formulated-object :prompt "Object" :gesture :menu)) + (remove-from-monitor object *application-frame*)) + (define-formulate-command (com-set-slot-value :name "Set Slot Value") - ((expression 'formulated-slot :prompt "Slot") - (new-value 'form :prompt "New value")) + ((expression 'formulated-slot :prompt "Slot" :gesture :select) + (new-value 'form :prompt "New value" :default *unsupplied-argument-marker*)) (destructuring-bind (s-v object (q slot)) expression (declare (ignore s-v q)) (setf (slot-value object slot) (eval new-value)))) -(define-presentation-to-command-translator set-slot-value - (formulated-slot com-set-slot-value formulate :gesture :select) - (object) - (list object - (accept 'form - :prompt (format nil "Set Slot Value (Slot) ~a (New value)" object)))) - (define-formulate-command (com-describe-slot :name "Describe Slot") ((expression 'formulated-slot :prompt "Slot" :gesture :describe)) (destructuring-bind (s-v object (q slot)) expression --- /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/19 01:17:18 1.1 +++ /project/rjain-utils/cvsroot/formulate/src/clim-ui/variables.lisp 2009/11/24 10:06:47 1.2 @@ -14,27 +14,28 @@ (let ((*standard-output* (get-frame-pane *application-frame* 'monitor))) (vector-push-extend name (monitored-values *application-frame*))))) +(define-presentation-type formulated-variable () + :inherit-from t) + (defmethod display-monitored-value ((name symbol)) (fresh-line) - (with-text-face (t :bold) - (present name 'symbol)) - (write-string " = ") - (display-formula-value (eval name))) + (with-output-as-presentation (t name 'formulated-variable) + (with-text-face (t :bold) + (present name 'symbol)) + (write-string " = ") + (display-formula-value (eval name)))) -(define-formulate-command (com-set-variable :name "Set Variable") - ((name 'symbol) (new-value 'form)) - (eval `(setf ,name ',value))) +(define-formulate-command (com-remove-variable :name "Remove Variable From Monitor") + ((name 'formulated-variable :prompt "Variable" :gesture :menu)) + (remove-from-monitor name *application-frame*)) -(define-presentation-to-command-translator set-variable - (symbol com-set-variable formulate :gesture :select) - (name) - (list name - (let ((stream t)) - (format stream " Set Variable (Name) ~a (New value) " name) - (accept 'form :prompt nil :stream stream)))) +(define-formulate-command (com-set-variable :name "Set Variable") + ((name 'formulated-variable :gesture :select) + (new-value 'form)) + (eval `(setf ,name ',new-value))) (define-formulate-command (com-describe-variable :name "Describe Variable") - ((name 'symbol :prompt "Name" :gesture :describe)) + ((name 'formulated-variable :prompt "Name" :gesture :describe)) (let ((formulator (let ((formulate::*get-formulator* t)) (eval name)))) (format t "Variable ~A is computed by ~A~%using formula ~A" From rjain at common-lisp.net Tue Nov 24 10:30:48 2009 From: rjain at common-lisp.net (rjain) Date: Tue, 24 Nov 2009 05:30:48 -0500 Subject: [rjain-utils-cvs] CVS prototypes Message-ID: Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv6398 Log Message: initial version Status: Vendor Tag: rjain Release Tags: INITIAL_IMPORT N prototypes/prototypes.lisp No conflicts created by this import From rjain at common-lisp.net Tue Nov 24 10:36:44 2009 From: rjain at common-lisp.net (rjain) Date: Tue, 24 Nov 2009 05:36:44 -0500 Subject: [rjain-utils-cvs] CVS prototypes Message-ID: Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv6722 Modified Files: prototypes.lisp Log Message: add delegation and all slot operations add tests --- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:30:48 1.1.1.1 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:36:43 1.2 @@ -1,5 +1,5 @@ (defpackage :prototypes - (:use :cl :sb-mop)) + (:use :cl #+sbcl :sb-mop #-sbcl :mop)) (in-package :prototypes) @@ -9,24 +9,85 @@ (defmethod validate-superclass ((proto prototype-class) (super standard-class)) t) -(defclass prototype-instance (standard-object) - () +(defclass prototype-object () + ((delegate :initarg :delegate :reader prototype-delegate :initform nil)) (:metaclass prototype-class)) +(defgeneric prototype-find-subclass (prototype slot-name)) + (defmethod prototype-find-subclass ((class prototype-class) slot-name) (find-if (lambda (subclass) (eql slot-name (slot-definition-name (first (class-direct-slots subclass))))) (class-direct-subclasses class))) -(defmethod slot-missing (class (object prototype-instance) slot-name (operation (eql 'setf)) &optional new-value) +(defmethod prototype-find-subclass ((object prototype-object) slot-name) + (prototype-find-subclass (class-of object) slot-name)) + +(defmethod slot-missing (class (object prototype-object) slot-name + (operation (eql 'slot-value)) + &optional new-value) + (if (null (prototype-delegate object)) + (call-next-method) + (slot-value (prototype-delegate object) slot-name))) + +(defmethod slot-missing (class (object prototype-object) slot-name + (operation (eql 'slot-boundp)) + &optional new-value) + (if (null (prototype-delegate object)) + (call-next-method) + (slot-boundp (prototype-delegate object) slot-name))) + +(defun prototype-subclass (class slot-name) + (make-instance 'prototype-class + :direct-superclasses (list class) + :direct-slots (list (list :name slot-name :initargs (list slot-name))))) + +(defmethod slot-missing (class (object prototype-object) slot-name + (operation (eql 'setf)) &optional new-value) (let ((new-class (or (prototype-find-subclass class slot-name) - (make-instance 'prototype-class - :direct-superclasses (list class) - :direct-slots (list (make-instance 'standard-direct-slot-definition :name slot-name :initarg slot-name)))))) - (change-class object slot-name new-class new-value))) - -(defmethod make-instance ((prototype prototype-instance) &key) - (apply #'make-instance (class-of prototype) - (mapcan (lambda (slot) (let ((name (slot-definition-name slot))) - (when (slot-boundp prototype name) - (list name (slot-value prototype name))))) - (class-slots (class-of prototype))))) + (prototype-subclass class slot-name)))) + (change-class object new-class slot-name new-value))) + +(defmethod slot-missing (class (object prototype-object) slot-name + (operation (eql 'slot-makunbound)) + &optional new-value) + (let ((new-class (or (prototype-find-subclass class slot-name) + (prototype-subclass class slot-name)))) + (change-class object new-class))) + +(defmethod make-instance ((prototype prototype-object) &key) + (make-instance 'prototype-object :delegate prototype)) + + +;;;; TESTS + +(defparameter *1* (make-instance 'prototype-object)) + +(setf (slot-value *1* 'x) 1) + +(defparameter *2* (make-instance *1*)) + +(assert (eql (slot-value *2* 'x) 1)) + +(defparameter *3* (make-instance *2*)) + +(assert (eql (slot-value *3* 'x) 1)) + +(defparameter *3.1* (make-instance *2*)) + +(assert (eql (slot-value *3.1* 'x) 1)) + +(setf (slot-value *2* 'x) 2) + +(assert (eql (slot-value *2* 'x) 2)) + +(assert (eql (slot-value *3* 'x) 2)) + +(assert (eql (slot-value *3.1* 'x) 2)) + +(setf (slot-value *3* 'x) 3) + +(assert (eql (slot-value *2* 'x) 2)) + +(assert (eql (slot-value *3* 'x) 3)) + +(assert (eql (slot-value *3.1* 'x) 2)) From rjain at common-lisp.net Tue Nov 24 10:38:19 2009 From: rjain at common-lisp.net (rjain) Date: Tue, 24 Nov 2009 05:38:19 -0500 Subject: [rjain-utils-cvs] CVS prototypes Message-ID: Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv6830 Modified Files: prototypes.lisp Log Message: add multiple delegation macrolet for slot operation definition --- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:36:43 1.2 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:38:19 1.3 @@ -10,53 +10,52 @@ t) (defclass prototype-object () - ((delegate :initarg :delegate :reader prototype-delegate :initform nil)) + ((delegates :initarg :delegates :reader prototype-delegates :initform nil)) (:metaclass prototype-class)) (defgeneric prototype-find-subclass (prototype slot-name)) (defmethod prototype-find-subclass ((class prototype-class) slot-name) - (find-if (lambda (subclass) (eql slot-name (slot-definition-name (first (class-direct-slots subclass))))) - (class-direct-subclasses class))) + (find slot-name + (class-direct-subclasses class) + :key (lambda (subclass) + (slot-definition-name (first (class-direct-slots subclass)))))) (defmethod prototype-find-subclass ((object prototype-object) slot-name) (prototype-find-subclass (class-of object) slot-name)) -(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql 'slot-value)) - &optional new-value) - (if (null (prototype-delegate object)) - (call-next-method) - (slot-value (prototype-delegate object) slot-name))) - -(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql 'slot-boundp)) - &optional new-value) - (if (null (prototype-delegate object)) - (call-next-method) - (slot-boundp (prototype-delegate object) slot-name))) - (defun prototype-subclass (class slot-name) (make-instance 'prototype-class :direct-superclasses (list class) :direct-slots (list (list :name slot-name :initargs (list slot-name))))) -(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql 'setf)) &optional new-value) - (let ((new-class (or (prototype-find-subclass class slot-name) - (prototype-subclass class slot-name)))) - (change-class object new-class slot-name new-value))) - -(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql 'slot-makunbound)) - &optional new-value) - (let ((new-class (or (prototype-find-subclass class slot-name) - (prototype-subclass class slot-name)))) - (change-class object new-class))) +(defun ensure-subclass (class slot-name) + (or (prototype-find-subclass class slot-name) + (prototype-subclass class slot-name))) + +(macrolet ((reader-delegation (operation) + `(defmethod slot-missing (class (object prototype-object) slot-name + (operation (eql ',operation)) + &optional new-value) + (declare (ignore new-value)) + (dolist (delegate (prototype-delegates object) + (call-next-method)) + (ignore-errors + (return (,operation delegate slot-name))))))) + (reader-delegation slot-value) + (reader-delegation slot-boundp)) + +(macrolet ((writer-subclassing (operation &rest initargs) + `(defmethod slot-missing (class (object prototype-object) slot-name + (operation (eql ',operation)) + &optional new-value) + (let ((new-class (ensure-subclass class slot-name))) + (change-class object new-class , at initargs))))) + (writer-subclassing setf slot-name new-value) + (writer-subclassing slot-makunbound)) (defmethod make-instance ((prototype prototype-object) &key) - (make-instance 'prototype-object :delegate prototype)) - + (make-instance 'prototype-object :delegates (list prototype))) ;;;; TESTS @@ -91,3 +90,11 @@ (assert (eql (slot-value *3* 'x) 3)) (assert (eql (slot-value *3.1* 'x) 2)) + +(slot-makunbound *3.1* 'x) + +(assert (eql (slot-value *2* 'x) 2)) + +(assert (eql (slot-value *3* 'x) 3)) + +(assert (not (slot-boundp *3.1* 'x))) From rjain at common-lisp.net Tue Nov 24 10:40:13 2009 From: rjain at common-lisp.net (rjain) Date: Tue, 24 Nov 2009 05:40:13 -0500 Subject: [rjain-utils-cvs] CVS prototypes Message-ID: Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv7378 Modified Files: prototypes.lisp Log Message: removed metaclass added stdandard-object subclassing added subclass caching --- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:38:19 1.3 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:40:13 1.4 @@ -1,32 +1,54 @@ (defpackage :prototypes + (:export #:prototype-object + #:prototype-delegates + #:prototype-add-delegate + #:prototype-remove-delegate + #:make-prototype) (:use :cl #+sbcl :sb-mop #-sbcl :mop)) (in-package :prototypes) -(defclass prototype-class (standard-class) - ()) - -(defmethod validate-superclass ((proto prototype-class) (super standard-class)) - t) (defclass prototype-object () - ((delegates :initarg :delegates :reader prototype-delegates :initform nil)) - (:metaclass prototype-class)) + ((%delegates :initarg :delegates + :reader prototype-delegates + :writer %set-prototype-delegates + :initform nil))) + +(defmethod prototype-add-delegate ((object prototype-object) (delegate prototype-object)) + (loop for tail on (prototype-delegates object) + until (eql object (car tail)) + finally (setf (cdr tail) (list delegate)))) + +(defmethod prototype-remove-delegate ((object prototype-object) (delegate prototype-object)) + (%set-prototype-delegates object (delete delegate (prototype-delegates object)))) + +(defun memoize-method-result (generic-function specializers result) + (add-method generic-function + (make-instance 'standard-method + :lambda-list (mapcar (lambda (x) + (make-symbol (write-to-string x :escape nil))) + specializers) + :specializers specializers + :function (constantly result)))) (defgeneric prototype-find-subclass (prototype slot-name)) -(defmethod prototype-find-subclass ((class prototype-class) slot-name) - (find slot-name - (class-direct-subclasses class) - :key (lambda (subclass) - (slot-definition-name (first (class-direct-slots subclass)))))) - -(defmethod prototype-find-subclass ((object prototype-object) slot-name) - (prototype-find-subclass (class-of object) slot-name)) - -(defun prototype-subclass (class slot-name) - (make-instance 'prototype-class - :direct-superclasses (list class) +(defmethod prototype-find-subclass ((object prototype-object) (slot-name symbol)) + (let ((subclass (find slot-name + (class-direct-subclasses (class-of object)) + :key (lambda (subclass) + (slot-definition-name (first (class-direct-slots subclass))))))) + (when subclass + (memoize-method-result #'prototype-find-subclass + (list (class-of object) + (intern-eql-specializer slot-name)) + subclass)) + subclass)) + +(defun prototype-subclass (object slot-name) + (make-instance 'standard-class + :direct-superclasses (list (class-of object)) :direct-slots (list (list :name slot-name :initargs (list slot-name))))) (defun ensure-subclass (class slot-name) @@ -34,8 +56,8 @@ (prototype-subclass class slot-name))) (macrolet ((reader-delegation (operation) - `(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql ',operation)) + `(defmethod slot-missing (class (object prototype-object) + slot-name (operation (eql ',operation)) &optional new-value) (declare (ignore new-value)) (dolist (delegate (prototype-delegates object) @@ -46,21 +68,51 @@ (reader-delegation slot-boundp)) (macrolet ((writer-subclassing (operation &rest initargs) - `(defmethod slot-missing (class (object prototype-object) slot-name - (operation (eql ',operation)) - &optional new-value) - (let ((new-class (ensure-subclass class slot-name))) - (change-class object new-class , at initargs))))) + `(defmethod slot-missing (class (object prototype-object) + slot-name (operation (eql ',operation)) + &optional new-value) + (let ((new-class (ensure-subclass object slot-name))) + (change-class object new-class , at initargs))))) (writer-subclassing setf slot-name new-value) (writer-subclassing slot-makunbound)) (defmethod make-instance ((prototype prototype-object) &key) (make-instance 'prototype-object :delegates (list prototype))) +(defgeneric find-std-class-prototype (class)) + +(defmethod find-std-class-prototype ((class standard-class)) + (let ((subclass (find-if (lambda (subclass) (subtypep subclass class)) + (class-direct-subclasses (find-class 'prototype-object)) + :key (lambda (subclass) + (first (class-direct-superclasses subclass)))))) + (when subclass + (memoize-method-result #'find-std-class-prototype + (list (intern-eql-specializer class)) + subclass)) + subclass)) + +(defun make-std-class-prototype (class) + (make-instance 'standard-class + :direct-superclasses (list class + (find-class 'prototype-object)))) + +(defun ensure-std-class-prototype (class) + (or (find-std-class-prototype class) + (make-std-class-prototype class))) + +(defgeneric make-prototype (class &key delegates)) + +(defmethod make-prototype ((class-name symbol) &key delegates) + (make-prototype (find-class class-name) :delegates delegates)) + +(defmethod make-prototype ((class standard-class) &key delegates) + (make-instance (ensure-std-class-prototype class) + :delegates delegates)) + ;;;; TESTS (defparameter *1* (make-instance 'prototype-object)) - (setf (slot-value *1* 'x) 1) (defparameter *2* (make-instance *1*)) @@ -75,26 +127,51 @@ (assert (eql (slot-value *3.1* 'x) 1)) +(defparameter *3.3.1* (make-instance 'prototype-object :delegates (list *3.1* *3*))) + (setf (slot-value *2* 'x) 2) (assert (eql (slot-value *2* 'x) 2)) - (assert (eql (slot-value *3* 'x) 2)) - (assert (eql (slot-value *3.1* 'x) 2)) +(assert (eql (slot-value *3.3.1* 'x) 2)) (setf (slot-value *3* 'x) 3) (assert (eql (slot-value *2* 'x) 2)) - (assert (eql (slot-value *3* 'x) 3)) - (assert (eql (slot-value *3.1* 'x) 2)) +(assert (eql (slot-value *3.3.1* 'x) 2)) (slot-makunbound *3.1* 'x) (assert (eql (slot-value *2* 'x) 2)) - (assert (eql (slot-value *3* 'x) 3)) - (assert (not (slot-boundp *3.1* 'x))) +(assert (not (slot-boundp *3.3.1* 'x))) + +(defclass test () + ((x :allocation :class))) + +;; need to always reset the slot value because we change it below +(finalize-inheritance (find-class 'test)) +(setf (slot-value (class-prototype (find-class 'test)) 'x) :test) + +(defparameter *t* (make-prototype 'test)) + +(assert (eql (slot-value *t* 'x) :test)) + +(defparameter *3.t* (make-instance 'prototype-object + :delegates (list *3* (make-prototype 'test)))) + +(assert (eql (slot-value *3.t* 'x) 3)) + +(defparameter *t.3* (make-prototype 'test :delegates (list *3*))) + +(assert (eql (slot-value *t.3* 'x) :test)) + +(setf (slot-value *t* 'x) :t) + +(assert (eql (slot-value *t* 'x) :t)) +(assert (eql (slot-value *3.t* 'x) 3)) +(assert (eql (slot-value *t.3* 'x) :t)) From rjain at common-lisp.net Tue Nov 24 10:43:30 2009 From: rjain at common-lisp.net (rjain) Date: Tue, 24 Nov 2009 05:43:30 -0500 Subject: [rjain-utils-cvs] CVS prototypes Message-ID: Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv9460 Modified Files: prototypes.lisp Log Message: documentation robustness initiarg processing during instance creation --- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:40:13 1.4 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:43:30 1.5 @@ -8,29 +8,65 @@ (in-package :prototypes) +;;;; +;;;; PROTOTYPE-OBJECT +;;;; (defclass prototype-object () ((%delegates :initarg :delegates :reader prototype-delegates :writer %set-prototype-delegates - :initform nil))) + :initform nil)) + (:documentation "The root of the prototype hierarchy. Instantiate this + class to create a new prototype, possibly initializing it with + a :DELEGATES argument to provide a list of other prototype instances + that slots will be inherited from.")) + +(defgeneric prototype-add-delegate (object delegate) + ;; TODO: test case + ;; Maybe indicate whether delegate was already there? + (:documentation "Adds a DELEGATE to the end of OBJECT's delegates, if + it is not already there. Returns no values.") + (:method ((object prototype-object) (delegate prototype-object)) + (if (prototype-delegates object) + (loop for tail on (prototype-delegates object) + until (eql delegate (car tail)) + finally (setf (cdr tail) (list delegate))) + (%set-prototype-delegates (list delegate) object)) + (values))) + +(defgeneric prototype-remove-delegate (object delegate) + ;; TODO: test case + ;; Maybe indicate whether delegate was actually found? + (:documentation "Removes DELEGATE from OBJECT's delegates, if it is + there. Returns no values.") + (:method ((object prototype-object) (delegate prototype-object)) + (%set-prototype-delegates (delete delegate (prototype-delegates object)) + object) + (values))) + +;;;; +;;;; Utility for memoization of searches +;;;; -(defmethod prototype-add-delegate ((object prototype-object) (delegate prototype-object)) - (loop for tail on (prototype-delegates object) - until (eql object (car tail)) - finally (setf (cdr tail) (list delegate)))) - -(defmethod prototype-remove-delegate ((object prototype-object) (delegate prototype-object)) - (%set-prototype-delegates object (delete delegate (prototype-delegates object)))) +(defun symbolicate (x) + (make-symbol (write-to-string x :escape nil))) (defun memoize-method-result (generic-function specializers result) - (add-method generic-function - (make-instance 'standard-method - :lambda-list (mapcar (lambda (x) - (make-symbol (write-to-string x :escape nil))) - specializers) - :specializers specializers - :function (constantly result)))) + (restart-case + (add-method generic-function + (make-instance 'standard-method + :lambda-list (mapcar #'symbolicate + specializers) + :specializers specializers + :function (constantly result))) + (disable-memoization () + :report "Disable memoization and continue." + (setf (symbol-function 'memoize-method-result) (constantly nil))))) + +;;;; +;;;; Prototype backend class search and generation +;;;; (defgeneric prototype-find-subclass (prototype slot-name)) @@ -55,6 +91,13 @@ (or (prototype-find-subclass class slot-name) (prototype-subclass class slot-name))) +;;;; +;;;; Additional functionality needed for prototype object manipulation +;;;; beyond what CLOS gives us for free +;;;; + +;;; TODO: Delegate down a linearized precedence list. Maybe offer both +;;; CLOS and C3 linearization algorithms. (macrolet ((reader-delegation (operation) `(defmethod slot-missing (class (object prototype-object) slot-name (operation (eql ',operation)) @@ -63,6 +106,12 @@ (dolist (delegate (prototype-delegates object) (call-next-method)) (ignore-errors + ;; if OPERATION succeeds on the delegate, RETURN + ;; that result from our loop, otherwise it will + ;; error and continue on to the next delegate, via + ;; IGNORE-ERRORS. If no delegates are left, it will + ;; call the default method which signals a + ;; slot-missing error. (return (,operation delegate slot-name))))))) (reader-delegation slot-value) (reader-delegation slot-boundp)) @@ -76,8 +125,21 @@ (writer-subclassing setf slot-name new-value) (writer-subclassing slot-makunbound)) -(defmethod make-instance ((prototype prototype-object) &key) - (make-instance 'prototype-object :delegates (list prototype))) +;;;; +;;;; Shortcut for single-inheritance +;;;; + +(defmethod make-instance ((prototype prototype-object) &rest initargs + &key &allow-other-keys) + "Create a PROTOTYPE-OBJECT that delegates to the given PROTOTYPE." + (let ((object (make-instance 'prototype-object :delegates (list prototype)))) + (loop for (slot-name value) on initargs by #'cddr + do (setf (slot-value object slot-name) value)) + object)) + +;;;; +;;;; Subclassing of CLOS classes as prototype objects +;;;; (defgeneric find-std-class-prototype (class)) @@ -101,16 +163,22 @@ (or (find-std-class-prototype class) (make-std-class-prototype class))) -(defgeneric make-prototype (class &key delegates)) - -(defmethod make-prototype ((class-name symbol) &key delegates) - (make-prototype (find-class class-name) :delegates delegates)) - -(defmethod make-prototype ((class standard-class) &key delegates) - (make-instance (ensure-std-class-prototype class) - :delegates delegates)) +(defgeneric make-prototype (class &rest initargs + &key delegates &allow-other-keys) + (:documentation "Create a prototype instance that is an instance of + CLASS, initializing it with the given INITARGS, which may + include :DELEGATES to specify the instance's delegates.")) + +(defmethod make-prototype ((class-name symbol) &rest initargs) + (apply #'make-prototype (find-class class-name) initargs)) + +(defmethod make-prototype ((class standard-class) &rest initargs) + (apply #'make-instance (ensure-std-class-prototype class) + initargs)) +;;;; ;;;; TESTS +;;;; (defparameter *1* (make-instance 'prototype-object)) (setf (slot-value *1* 'x) 1) @@ -174,4 +242,4 @@ (assert (eql (slot-value *t* 'x) :t)) (assert (eql (slot-value *3.t* 'x) 3)) -(assert (eql (slot-value *t.3* 'x) :t)) +(assert (eql (slot-value *t.3* 'x) :t)) ; The slot is class-allocated, remember! From rjain at common-lisp.net Wed Nov 25 10:46:36 2009 From: rjain at common-lisp.net (rjain) Date: Wed, 25 Nov 2009 05:46:36 -0500 Subject: [rjain-utils-cvs] CVS prototypes Message-ID: Update of /project/rjain-utils/cvsroot/prototypes In directory cl-net:/tmp/cvs-serv4504 Modified Files: prototypes.lisp Log Message: use CLOSER-MOP allow slot-unbound errors to propagate out of slot-value accessors add test case for above change --- /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/24 10:43:30 1.5 +++ /project/rjain-utils/cvsroot/prototypes/prototypes.lisp 2009/11/25 10:46:36 1.6 @@ -4,7 +4,7 @@ #:prototype-add-delegate #:prototype-remove-delegate #:make-prototype) - (:use :cl #+sbcl :sb-mop #-sbcl :mop)) + (:use :cl :closer-mop)) (in-package :prototypes) @@ -104,14 +104,20 @@ &optional new-value) (declare (ignore new-value)) (dolist (delegate (prototype-delegates object) + ;; if no slot is found in all the delegates, we + ;; call the default method to signal a + ;; slot-missing error (call-next-method)) - (ignore-errors - ;; if OPERATION succeeds on the delegate, RETURN - ;; that result from our loop, otherwise it will - ;; error and continue on to the next delegate, via - ;; IGNORE-ERRORS. If no delegates are left, it will - ;; call the default method which signals a - ;; slot-missing error. + (handler-bind ((unbound-slot #'error) + ;; there is no specific class for + ;; slot-missing errors. the spec just + ;; says signals an error of type error. + ;; ugh. + (error + ;; can't find the slot here, so we + ;; continue to the next delegate + #'identity)) + ;; if this finds the slot, we return it (return (,operation delegate slot-name))))))) (reader-delegation slot-value) (reader-delegation slot-boundp)) @@ -217,6 +223,11 @@ (assert (eql (slot-value *3* 'x) 3)) (assert (not (slot-boundp *3.1* 'x))) (assert (not (slot-boundp *3.3.1* 'x))) +(handler-case + (progn + (slot-value *3.3.1* 'x) + (assert nil)) + (unbound-slot (error))) (defclass test () ((x :allocation :class)))