From 079b90842fc99823554991ff3e739da9a5d42d97 Mon Sep 17 00:00:00 2001 From: drewc Date: Thu, 6 Sep 2007 18:54:00 -0700 Subject: [PATCH] Include some more new stuff. darcs-hash:20070907015400-39164-71316e7286cc62a488fddc338ada5b0ab5c41cda.gz --- lisp-on-lines.asd | 14 +++++------ src/attribute.lisp | 14 +++++++---- src/display-test.lisp | 4 +-- src/packages-test.lisp | 3 +++ src/packages.lisp | 19 ++++++++------ src/utilities.lisp | 56 ++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 88 insertions(+), 22 deletions(-) create mode 100644 src/packages-test.lisp create mode 100644 src/utilities.lisp diff --git a/lisp-on-lines.asd b/lisp-on-lines.asd index e8633cb..993a672 100644 --- 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 --- 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 --- 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 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 --- 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 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)))))) + + + -- 2.20.1