| 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 | |
HCoop / clinton / lisp-on-lines.git / blame