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 | |