Include some more new stuff.

darcs-hash:20070907015400-39164-71316e7286cc62a488fddc338ada5b0ab5c41cda.gz

diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd
index e8633cb..993a672 100644 (file)
--- a/lisp-on-lines.asd
+++ b/lisp-on-lines.asd
@@ -40,24 +40,24 @@ OTHER DEALINGS IN THE SOFTWARE."
               (:module :src
                        :components ((:file "packages")
                                     (:file "utilities")
+                                    
                                     (:file "display")
                                     
                                     (:file "attribute")
 
                                     (:file "description-class")
-                                    (:file "description")
                                     
-
-                                    (:file "description-test")
-                                    (:file "attribute-test"))
+                                    (:file "description"))
                        :serial t))
   :serial t
-  :depends-on (:contextl))
+  :depends-on (:contextl :arnesi))
 
 (defsystem :lisp-on-lines.test
   :components ((:module :src
-                       :components ((:file "description-test")
-                                    (:file "attribute-test"))
+                       :components ((:file "packages-test")
+                                    (:file "description-test")
+                                    (:file "attribute-test")
+                                    (:file "display-test"))
                        :serial t))
 
   :depends-on (:lisp-on-lines :stefil))

diff --git a/src/attribute.lisp b/src/attribute.lisp
index 2e3877e..32279fe 100644 (file)
--- a/src/attribute.lisp
+++ b/src/attribute.lisp
@@ -10,11 +10,9 @@
 
 (defmethod eval-attribute-initarg (attribute (initarg (eql :function)))
   t)
-
 (define-layered-function attribute-value (object attribute))
 
-(define-layered-method attribute-value (object attribute)
- (funcall (attribute-function attribute) object))
+
               
 (deflayer LISP-ON-LINES)
 (ensure-active-layer 'lisp-on-lines)
@@ -30,7 +28,8 @@
   (initargs))
 
 (defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs )
-  (setf (slot-value instance 'initargs) (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
+  (setf (slot-value instance 'initargs) 
+       (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
   (call-next-method))
 
 (define-layered-class standard-attribute 
@@ -51,6 +50,11 @@
     :initarg :value
     :layered t)))
 
+(define-layered-method attribute-value (object attribute)
+ (funcall (attribute-function attribute) object))
+
+
+
 (defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
   (declare (ignore initargs))
     (setf (attribute-function attribute) 
@@ -74,7 +78,7 @@
   ((attribute standard-attribute) display object &rest args)
  (declare (ignore args))
  (format display "~@[~A ~]~A" (attribute-label attribute) 
-        (display display (attribute-value object attribute))))
+        (attribute-value object attribute)))
 
 
 

diff --git a/src/display-test.lisp b/src/display-test.lisp
index 7bef6ef..91068bd 100644 (file)
--- a/src/display-test.lisp
+++ b/src/display-test.lisp
@@ -13,9 +13,9 @@
 
   (let ((before (display-using-description 
                 (find-description 'attribute-test-2) 
-                nil *object*)))
+                nil :foo)))
     (with-active-layers (test-display)
       (is (equalp "BRILLANT!" (display-using-description 
                               (find-description 'attribute-test-2) 
-                              nil *object*))))))
+                              nil :foo))))))
                  
\ No newline at end of file

diff --git a/src/packages-test.lisp b/src/packages-test.lisp
new file mode 100644 (file)
index 0000000..7b807af
--- /dev/null
+++ b/src/packages-test.lisp
@@ -0,0 +1,3 @@
+
+(cl:defpackage #:lol-test
+    (:use #:cl #:lisp-on-lines #:stefil #:contextl))
\ No newline at end of file

diff --git a/src/packages.lisp b/src/packages.lisp
index b0aa651..b1f48db 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -1,22 +1,25 @@
 (defpackage #:lisp-on-lines
   (:use 
-       #:common-lisp
-       #:contextl)
+   :common-lisp
+   #:contextl)
   (:nicknames #:lol)
-
   (:export
-
+   
+;; Descriptions
    #:find-description
-   #:ensure-description
    #:define-description
-
+   
+   ;; Displays
    #:define-display
    #:display
+   #:display-using-description
    #:*display*
    #:*object*
    
+   ;; Attributes
    #:find-attribute
    #:attribute-label
+   #:attribute-function
+   #:attribute-value))
+
 
-(cl:defpackage #:lol-test
-  (:use #:cl #:lisp-on-lines #:stefil #:contextl))

diff --git a/src/utilities.lisp b/src/utilities.lisp
new file mode 100644 (file)
index 0000000..5dc0038
--- /dev/null
+++ b/src/utilities.lisp
@@ -0,0 +1,56 @@
+(in-package :lisp-on-lines)
+
+(defun make-enclosing-package (name)
+  (make-package name :use '()))
+
+(defgeneric enclose-symbol (symbol package)
+  (:method ((symbol symbol)
+            (package package))
+   (if (symbol-package symbol)
+     (intern (format nil "~A::~A"
+                     (package-name (symbol-package symbol))
+                     (symbol-name symbol))
+             package)
+     (or (get symbol package)
+         (setf (get symbol package) (gensym))))))
+
+#|
+Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
+|#
+
+
+(defvar *description-definers*
+  (make-enclosing-package "DESCRIPTION-DEFINERS"))
+
+(defun defining-description (name)
+  "Takes the name of a layer and returns its internal name."
+  (case name
+    ((t) 't)
+    ((nil) (error "NIL is not a valid description name."))
+    (otherwise (enclose-symbol name *description-definers*))))
+
+
+(defmethod initargs.slot-names (class)
+  "Returns ALIST of (initargs) . slot-name."
+  (nreverse (mapcar #'(lambda (slot)
+             (cons (closer-mop:slot-definition-initargs slot)
+                   (closer-mop:slot-definition-name slot)))
+         (closer-mop:class-slots class))))
+
+(defun find-slot-name-from-initarg (class initarg)
+  (cdr (assoc-if #'(lambda (x) (member initarg x))
+                                  (initargs.slot-names class))))
+  
+
+;;;!-- TODO: this has been so mangled that, while working, it's ooogly! 
+(defun initargs-plist->special-slot-bindings (class initargs-plist)
+  "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
+  (let ((initargs.slot-names-alist (initargs.slot-names class)))
+    (loop for (initarg value) on initargs-plist
+         nconc (let ((slot-name
+                   ))
+                 (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
+                   (list slot-name value))))))
+
+
+