November 2009 - rjain-utils-cvs@common-lisp.net

[rjain-utils-cvs] CVS prototypes
by rjain 25 Nov '09

25 Nov '09

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)))

1 0

[rjain-utils-cvs] CVS prototypes
by rjain 24 Nov '09

24 Nov '09

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!

1 0

[rjain-utils-cvs] CVS prototypes
by rjain 24 Nov '09

24 Nov '09

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 ,@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 ,@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))

1 0

[rjain-utils-cvs] CVS prototypes
by rjain 24 Nov '09

24 Nov '09

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 ,@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)))

1 0

[rjain-utils-cvs] CVS prototypes
by rjain 24 Nov '09

24 Nov '09

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))

1 0

[rjain-utils-cvs] CVS prototypes
by rjain 24 Nov '09

24 Nov '09

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

1 0

[rjain-utils-cvs] CVS formulate/src/clim-ui
by rjain 24 Nov '09

24 Nov '09

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 <object> <slot-name>) :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"

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 19 Nov '09

19 Nov '09

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

1 0

[rjain-utils-cvs] CVS formulate/src/clim-ui
by rjain 19 Nov '09

19 Nov '09

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 <object> <slot-name>) :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))))

1 0

[rjain-utils-cvs] CVS formulate/src
by rjain 19 Nov '09

19 Nov '09

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 ,@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))

1 0