X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/eeed4326c3330d13ba9f8b8b06254d7a370a5d85..6d0aa5eb12e458b11041b5bce3c80e9378dd34dc:/src/new-description.lisp

diff --git a/src/new-description.lisp b/src/new-description.lisp
deleted file mode 100644
index 1475ef7..0000000
--- a/src/new-description.lisp
+++ /dev/null
@@ -1,180 +0,0 @@
-(in-package :lisp-on-lines)
-
-;;;; A simpler implementation of descriptions based on plists
-
-(setf (find-class 'simple-attribute nil) nil)
-
-(define-layered-class simple-attribute ()
-  ((%property-access-function 
-    :initarg property-access-function)
-   (%initial-slot-values-plist)))
-
-(defun ensure-property-access-function (attribute)
-  (if (slot-boundp attribute '%property-access-function)
-      (slot-value attribute '%property-access-function)
-      (let ((fn-name (gensym))) 
-	(ensure-layered-function fn-name :lambda-list '() :method-combination '(append))
-	(setf (slot-value attribute '%property-access-function) fn-name))))
-
-(defconstant +property-not-found+ '=lisp-on-lines-property-not-found-indicator=)
-
-(define-layered-method 
-    contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
-  (if (or contextl:*symbol-access*  
-	  (not (slot-definition-layeredp slotd)))
-      (call-next-method)
-      (let ((value (getf (funcall (ensure-property-access-function attribute))
-			 (slot-definition-name slotd)
-			 +property-not-found+)))
-	(if (eq value +property-not-found+)
-	    (call-next-method)
-	    value))))
-
-(define-layered-method 
-    contextl:slot-value-using-layer (class (attribute simple-attribute) slotd reader)
-  (if (or contextl:*symbol-access*  
-	  (not (slot-definition-layeredp slotd))
-	  (dynamic-symbol-boundp (with-symbol-access (call-next-method))))
-      (call-next-method)     
-      (let ((value (getf (ignore-errors (funcall (ensure-property-access-function attribute)))
-			 (slot-definition-name slotd)
-			 +property-not-found+)))
-	(if (eq value +property-not-found+)
-	    (let ((value (get (ensure-property-access-function attribute) 
-			      (slot-definition-name slotd)
-			      +property-not-found+)))
-	      	(if (eq value +property-not-found+)
-		    (call-next-method)
-		    value))
-	    value))))
-
-(define-layered-method 
-    (setf contextl:slot-value-using-layer) (value class (attribute simple-attribute) slotd reader)
- (if (and (not contextl:*symbol-access*)
-	  (slot-definition-layeredp slotd)) 
-     (setf (get (ensure-property-access-function attribute) (slot-definition-name slotd))
-	   value)
-     (call-next-method)))
-
-(defmethod initialize-attribute-for-layer (attribute layer-name &rest args)
-  (let* ((class (class-of attribute))
-	 (slotds (class-slots class)))    
-    (ensure-layered-method 
-     (ensure-property-access-function attribute)
-     `(lambda ()
-	',(loop 
-	     :for (key val) :on args :by #'cddr 
-	     :nconc (list 
-		     (loop 
-			:for slotd :in slotds 
-			:do (when (find key (slot-definition-initargs slotd))
-			      (return  (slot-definition-name slotd))))
-		     val))) 
-     :qualifiers '(append)
-     :in-layer layer-name)))
-
-
-(define-layered-class direct-attribute-slot-definition-class 
-  (special-layered-direct-slot-definition 
-   contextl::singleton-direct-slot-definition)
-  ((attribuite-properties
-    :accessor slot-definition-attribute-properties
-    :documentation "Holds the initargs passed to the slotd")))
-
-(defmethod initialize-instance 
-    :after ((slotd direct-attribute-slot-definition-class) 
-	    &rest initargs)
-  (setf (slot-definition-attribute-properties slotd) initargs))
-
-(defmethod reinitialize-instance 
-    :after ((slotd direct-attribute-slot-definition-class) 
-	    &rest initargs)
-  (setf (slot-definition-attribute-properties slotd) initargs))
-
-(define-layered-class effective-attribute-slot-definition-class 
-    (special-layered-effective-slot-definition) 
-    ((attribute-object 
-      :accessor slot-definition-attribute-object)))
-
-(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class)
-  ((defined-in-descriptions :initarg :in-description)
-   (class-active-attributes-definition :initarg :attributes)
-   (mixin-class-p :initarg :mixinp)))
-
-(defmethod direct-slot-definition-class
-           ((class description-access-class) &key &allow-other-keys)
-  (find-class 'direct-attribute-slot-definition-class))
-
-(defmethod effective-slot-definition-class
-           ((class description-access-class) &key &allow-other-keys)
-  (find-class 'effective-attribute-slot-definition-class))
-(fmakunbound 'initialize-slot-definition-attribute)
-
-(defmethod initialize-slot-definition-attribute ((slotd effective-attribute-slot-definition-class) name direct-slot-definitions)
-  (let ((tbl (make-hash-table))
-	(attribute (make-instance 'simple-standard-attribute :name name)))
-    (loop for ds in direct-slot-definitions
-	 :when (typep ds 'direct-attribute-slot-definition-class)
-       :do (setf (gethash (slot-definition-layer ds) tbl)
-		 (append (gethash (slot-definition-layer ds) tbl '()) 
-			 (slot-definition-attribute-properties ds))))
-    (maphash (lambda (layer properties)
-	       (apply #'initialize-attribute-for-layer attribute layer properties))
-	     tbl)
-    (setf (slot-definition-attribute-object slotd) attribute)))
-
-(defmethod compute-effective-slot-definition
-           ((class description-access-class) name direct-slot-definitions)
-  (declare (ignore name))
-  (let ((slotd (call-next-method)))
-    (initialize-slot-definition-attribute slotd name direct-slot-definitions) 
-    slotd))
-
-(defclass standard-description-class (description-access-class layered-class)
-  ((attributes :accessor description-class-attributes :initform (list)))
-  (:default-initargs :defining-metaclass 'description-access-class))
-
-(defmethod validate-superclass
-           ((class standard-description-class)
-            (superclass standard-class))
-  t)
-
-(define-layered-class standard-description-object (standard-layer-object) 
-  ((described-object :accessor described-object 
-		     :special t)))
-
-(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
-  (declare (dynamic-extent initargs))
-  (prog1
-      (if (loop for direct-superclass in direct-superclasses
-		thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
-	(call-next-method)
-	(apply #'call-next-method
-	       class
-	       :direct-superclasses
-	       (append direct-superclasses
-		       (list (find-class 'standard-description-object)))
-	       initargs))))
-
-
-(defmethod reinitialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
-  (declare (dynamic-extent initargs))
-;  (warn "CLASS ~A ARGS ~A:" class initargs)
-  (prog1
-      (if (or (not direct-superclasses-p)
-		(loop for direct-superclass in direct-superclasses
-		      thereis (ignore-errors (subtypep direct-superclass 'standard-description-object))))
-	  (call-next-method)
-	  (apply #'call-next-method
-		 class
-		 :direct-superclasses
-		 (append direct-superclasses
-			 (list (find-class 'standard-description-object)))
-		 initargs))))
-
-
-
-
-
-
-