Adding new implementation of LoL to repository.
[clinton/lisp-on-lines.git] / src / attribute.lisp
CommitLineData
e7c5f95a 1(in-package :lisp-on-lines)
2
3
4(define-layered-class attribute ()
5 ())
6
7(defgeneric eval-attribute-initarg (attribute initarg)
8 (:method (a i)
9 nil))
10
11(defmethod eval-attribute-initarg (attribute (initarg (eql :function)))
12 t)
13
14(define-layered-function attribute-value (object attribute))
15
16(define-layered-method attribute-value (object attribute)
17 (funcall (attribute-function attribute) object))
18
19(deflayer LISP-ON-LINES)
20(ensure-active-layer 'lisp-on-lines)
21
22(defvar *standard-direct-slot-initarg-symbols*
23 '(:layered :class :in-layer :name :readers :writers :initargs :allow-other-keys :special))
24
25(define-layered-function special-slot-values (description slot-name)
26 (:method-combination append))
27
28(define-layered-class attribute-special-layered-direct-slot-definition
29 (attribute contextl::special-layered-direct-slot-definition)
30 (initargs))
31
32(defmethod shared-initialize :around ((instance attribute-special-layered-direct-slot-definition) slots &rest initargs )
33 (setf (slot-value instance 'initargs) (apply #'arnesi:remove-keywords initargs *standard-direct-slot-initarg-symbols*))
34 (call-next-method))
35
36(define-layered-class standard-attribute
37 (attribute contextl::layered-effective-slot-definition-in-layers)
38 ((direct-slots)
39 (description
40 :layered-accessor description-of)
41 (label
42 :initarg :label
43 :layered-accessor attribute-label
44 :layered t
45 :initform nil)
46 (function
47 :initarg :function
48 :layered-accessor attribute-function
49 :layered t)
50 (value
51 :initarg :value
52 :layered t)))
53
54(defmethod shared-initialize :around ((attribute standard-attribute) slots &rest initargs)
55 (declare (ignore initargs))
56 (setf (attribute-function attribute)
57 (lambda (object)
58 (slot-value attribute 'value)))
59 (call-next-method))
60
61(defun attribute-name (attribute)
62 (closer-mop:slot-definition-name attribute))
63
64(define-layered-method slot-value-using-layer
65; :in-layer lisp-on-lines
66 :around (class (attribute standard-attribute) slot reader)
67 (loop for (key var) on (special-slot-values (slot-value attribute 'description)
68 (attribute-name attribute))
69 :if (eq (closer-mop:slot-definition-name slot) key)
70 :do (return-from slot-value-using-layer var))
71 (call-next-method))
72
73(define-layered-method display-using-description
74 ((attribute standard-attribute) display object &rest args)
75 (declare (ignore args))
76 (format display "~@[~A ~]~A" (attribute-label attribute)
77 (display display (attribute-value object attribute))))
78
79
80
81
82
83
84
85
86