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