From 4271ab0badc43ec1c9ac5a9f71b8995702802234 Mon Sep 17 00:00:00 2001 From: drewc Date: Sat, 19 Jan 2008 02:55:10 -0800 Subject: [PATCH] Made attribute class layered darcs-hash:20080119105510-39164-d4770a42971da8caad06f1205a47e16dbda9edc9.gz --- src/attribute.lisp | 49 ++++++++++++++++++++--------- src/description-class.lisp | 16 +++++----- src/description.lisp | 22 ++++++++----- src/display.lisp | 9 ++++-- src/standard-descriptions/clos.lisp | 24 +++++++++++--- 5 files changed, 84 insertions(+), 36 deletions(-) diff --git a/src/attribute.lisp b/src/attribute.lisp index 6d47657..c536d40 100644 --- a/src/attribute.lisp +++ b/src/attribute.lisp @@ -42,7 +42,8 @@ (initfunctions :initform nil) (attribute-class :accessor attribute-class :initarg :attribute-class - :initform 'standard-attribute) + :initform 'standard-attribute + :layered t) (name :layered-accessor attribute-name :initarg :name) (label :layered-accessor attribute-label @@ -65,6 +66,21 @@ (print-unreadable-object (object stream :type nil :identity t) (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) +(defgeneric eval-property-initarg (att initarg) + (:method ((attribute standard-attribute) initarg) + nil) + (:method ((attribute standard-attribute) (initarg (eql :function))) + t)) + +(defun prepare-initargs (att args) + (loop + :for (key arg) + :on args :by #'cddr + :nconc (list key + (if (eval-property-initarg att key) + (eval arg) + arg)))) + (defvar *bypass-property-layered-function* nil) (define-layered-function property-layered-function (description attribute-name property-name) @@ -82,8 +98,7 @@ :in-layer (context t) (new-value class (attribute standard-attribute) property writer) - (when (or *bypass-property-layered-function* - (not (slot-definition-layeredp property))) + (when (or *bypass-property-layered-function*) (return-from slot-value-using-layer (call-next-method))) @@ -129,15 +144,15 @@ (ensure-layered-method fn `(lambda (description) - ,new-value) + (funcall ,(lambda() + new-value))) :in-layer layer :specializers (list (class-of (attribute-description attribute) )))))) (if (slot-boundp attribute 'description-class) (do-set-slot) - (push (lambda () (do-set-slot)) - (slot-value attribute 'initfunctions)))))) + (error "serrint wif no desc WTF!"))))) (define-layered-method slot-value-using-layer @@ -153,13 +168,17 @@ (unless (slot-boundp-using-class class attribute property) (slot-unbound class attribute (slot-definition-name property))) + (let ((val (call-next-method))) + (if (and + ;; Not special access + (not (symbolp val)) (contextl::slot-definition-layeredp property) (not *bypass-property-layered-function*)) - (let ((fn (call-next-method))) + (let ((fn val)) ;(dprint "... using fn ~A to get value" fn) (funcall fn layer (attribute-description attribute))) - (call-next-method))) + val))) (defmacro define-bypass-function (name function-name) `(defun ,name (&rest args) @@ -171,7 +190,7 @@ (define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class)) (defun slot-boundp-using-property-layered-function (class attribute property) - (dprint "plf boundp:") + ;(dprint "plf boundp:") (let* ((really-bound-p (real-slot-boundp-using-class class attribute property)) (fn (if really-bound-p @@ -181,11 +200,13 @@ (attribute-description attribute) (attribute-name attribute) (closer-mop:slot-definition-name property)))))) - (dprint "Slot was bound? ~A" really-bound-p) - ;; If the slot is unbound, we search for its layered-function - (if (generic-function-methods fn) - T - NIL))) + + (if (symbolp fn) + ;;special symbol access in process + T + (if (generic-function-methods fn) + T + NIL)))) (define-layered-method slot-boundp-using-layer :in-layer (layer t) diff --git a/src/description-class.lisp b/src/description-class.lisp index 5297dfd..895c7ed 100644 --- a/src/description-class.lisp +++ b/src/description-class.lisp @@ -33,7 +33,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *defined-descriptions* nil)) -(defclass description-access-class (standard-layer-class contextl::special-layered-access-class ) +(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class ) ((defined-in-descriptions :initarg :in-description) (mixin-class-p :initarg :mixinp))) @@ -107,14 +107,16 @@ (find (slot-definition-name direct-slot) attribute-objects :key #'attribute-name))) - (dprint "Re-initing") - (apply #'reinitialize-instance attribute - (print (direct-attribute-properties direct-slot))) - (when (not (eq (find-class (attribute-class attribute)) - (class-of attribute))) + (let ((initargs + (prepare-initargs attribute (direct-attribute-properties direct-slot)))) + + (apply #'reinitialize-instance attribute + initargs ) + (when (not (eq (find-class (attribute-class attribute)) + (class-of attribute))) (apply #'change-class attribute (attribute-class attribute) - (direct-attribute-properties direct-slot))) + initargs))) (setf (slot-value description (attribute-name attribute)) diff --git a/src/description.lisp b/src/description.lisp index 36211c4..c06a6f4 100644 --- a/src/description.lisp +++ b/src/description.lisp @@ -10,18 +10,24 @@ (defun find-attribute (description attribute-name) (slot-value description attribute-name)) -#+nil(mapcar (lambda (slotd) - (slot-value-using-class (class-of description) description slotd)) - (class-slots (class-of description))) + (defun description-attributes (description) - (mapcar #'attribute-object (class-slots (class-of description)))) + (mapcar (curry + #'slot-value-using-class + (class-of 'description) + description) + (class-slots (class-of description)))) + +(defvar *display-attributes* nil) +(defun attribute-active-p (attribute) + (or (null *display-attributes*) + (find (attribute-name attribute) *display-attributes*))) (define-layered-function attributes (description) (:method (description) (remove-if-not (lambda (attribute) - (and (eq (class-of description) - (print (slot-value attribute 'description-class))) + (and (attribute-active-p attribute) (some #'layer-active-p (mapcar #'find-layer (slot-definition-layers @@ -35,7 +41,7 @@ (destructuring-bind (&optional slots &rest options) options (let ((description-layers (cdr (assoc :in-description options)))) (if description-layers - `(eval-when (:compile-toplevel :load-toplevel :execute) + `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) ,@(loop :for layer :in description-layers @@ -44,7 +50,7 @@ ,@(acons :in-layer (defining-description layer) (remove :in-description options :key #'car))))) - `(eval-when (:compile-toplevel :load-toplevel :execute) + `(progn ;eval-when (:compile-toplevel :load-toplevel :execute) ; `(progn (defclass ,description-name ,(append (mapcar #'defining-description diff --git a/src/display.lisp b/src/display.lisp index 862cf98..5888f0b 100644 --- a/src/display.lisp +++ b/src/display.lisp @@ -10,8 +10,9 @@ (:documentation "Displays OBJECT via description using/in/with/on display")) -(defun display (display object &rest args) - (display-using-description (description-of object) display object args)) +(defun display (display object &rest args &key attributes ) + (let ((*display-attributes* attributes)) + (display-using-description (description-of object) display object args))) (define-layered-method display-using-description :around (description display object &rest args) @@ -19,9 +20,11 @@ (let ((*description* description) (*display* display) (*object* object)) - (call-next-method))) +(defun display/d (&rest args) + (apply #'display-using-description args)) + (define-layered-method display-using-description (description display object &rest args) diff --git a/src/standard-descriptions/clos.lisp b/src/standard-descriptions/clos.lisp index ec80d86..2824c2e 100644 --- a/src/standard-descriptions/clos.lisp +++ b/src/standard-descriptions/clos.lisp @@ -8,13 +8,29 @@ ((slot-name :initarg :slot-name :accessor attribute-slot-name))) (define-layered-method attribute-value (object (attribute slot-definition-attribute)) - (slot-value object (attribute-slot-name attribute))) + (if (slot-boundp object (attribute-slot-name attribute)) + + (slot-value object (attribute-slot-name attribute)) + (gensym "UNBOUND-SLOT-"))) + +(defmacro define-description-for-class (class-name &optional (name (intern (format nil "DESCRIPTION-FOR-~A" class-name)))) + `(progn + (define-description ,name (standard-object) + ,(loop :for slot in (class-slots (find-class class-name)) + :collect `(,(slot-definition-name slot) + :attribute-class slot-definition-attribute + :slot-name ,(slot-definition-name slot) + :label ,(slot-definition-name slot))) + (:mixinp t)) + (unless (ignore-errors (find-description ',class-name)) + (define-description ,class-name (,name) ())))) + (define-layered-method description-of ((object standard-object)) - (find-description 'standard-object)) - - + (or (ignore-errors (find-description (class-name (class-of object)))) + (find-description 'standard-object))) + -- 2.20.1