Adding new implementation of LoL to repository.

[clinton/lisp-on-lines.git] / src / description.lisp

diff --git a/src/description.lisp b/src/description.lisp
new file mode 100644 (file)
index 0000000..20362f8
--- /dev/null
+++ b/src/description.lisp
@@ -0,0 +1,75 @@
+(in-package :lisp-on-lines)
+
+(define-description description ())
+
+(defgeneric find-description-class (name &optional errorp)        
+  (:method ((name (eql t)) &optional errorp)
+    (declare (ignore errorp))
+    (find-class 'description t))
+  (:method ((name symbol) &optional errorp)
+    (or (find-class (defining-description name) errorp)
+       (find-description-class t)))
+  (:method ((description description) &optional errorp)
+    (declare (ignore errorp))
+    (class-of description)))
+
+(defun find-description (name)
+   (slot-value (find-description-class name) 'instance))
+
+(defun description-attributes (description)
+  (closer-mop:class-slots (find-description-class description)))
+
+(define-layered-function attributes (description))
+
+(define-layered-method attributes (description)
+ (description-attributes description))
+                      
+;;;!-- TODO: This is a prime candidate for optimization
+(defun find-attribute (description attribute-name)
+  (find attribute-name (description-attributes description) :key #'attribute-name))
+
+(define-display ((description description))
+  (format *display* "~{~A~%~}" 
+         (mapcar 
+          (lambda (attribute)
+            (with-output-to-string (*display*)
+              (display-attribute attribute)))
+          (attributes description))))
+
+(define-layered-method description-of (object)
+  (find-description 't))                             
+
+(define-layered-method description-of ((symbol symbol))
+  (find-description 'symbol))
+
+(define-description symbol ()
+  ((identity :label "Symbol:")
+   (name 
+    :function #'symbol-name
+    :label "Name:")
+   (value 
+    :label "Value:" 
+    :function 
+    (lambda (symbol)
+      (if (boundp symbol)
+         (symbol-value symbol)
+         "<UNBOUND>")))
+   (package :function #'symbol-package
+           :label "Package:")
+   (function :label "Function:"
+    :function               
+    (lambda (symbol)
+     (if (fboundp symbol)
+        (symbol-function symbol)
+        "<UNBOUND>")))))
+
+
+                     
+  
+
+
+
+
+  
+  
+