Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Modf-def now properly builds class accessors given a class definition…

… or the name of a class.
  • Loading branch information...
commit 576260e600bfcedc34b1f5f9b628c779441a908d 1 parent e327387
Zach Kost-Smith authored

Showing 1 changed file with 100 additions and 63 deletions. Show diff stats Hide diff stats

  1. +100 63 modf-def.lisp
163 modf-def.lisp
@@ -2,7 +2,7 @@
2 2 (in-package :modf)
3 3
4 4 (defpackage :modf-def
5   - (:use :cl :modf :iter)
  5 + (:use :cl :modf :iter)
6 6 (:shadow cl:defstruct cl:defclass)
7 7 (:export #:defstruct #:defclass
8 8 #:define-modf-for-class-slots
@@ -22,39 +22,41 @@
22 22 ;; functions) in order to define our Modf expansions
23 23 (declare (ignore defstruct))
24 24 (destructuring-bind (&key name
25   - (conc-name (concatenate 'string (symbol-name name) "-")) )
  25 + (conc-name (concatenate 'string (symbol-name name) "-")) )
26 26 (if (atom name-and-options) (list :name name-and-options)
27 27 (append
28 28 (list :name (first name-and-options))
29 29 (let ((conc-name-option
30   - (find :conc-name (rest name-and-options)
31   - :key (lambda (x) (if (atom x) x (first x))) )))
  30 + (find :conc-name (rest name-and-options)
  31 + :key (lambda (x) (if (atom x) x (first x))) )))
32 32 (if (or (atom conc-name-option) (null (rest conc-name-option)))
33 33 (list :conc-name "")
34 34 (list :conc-name (symbol-name (second conc-name-option))) ))))
35 35 (iter (for slot in slot-descriptions)
36   - (let ((accessor (intern (concatenate
37   - 'string conc-name
38   - (symbol-name (if (atom slot)
39   - slot
40   - (first slot) ))))))
41   - (collecting
42   - `(define-modf-function ,accessor 1 (new-val object)
43   - (let ((new-struct (copy-structure object)))
44   - (setf (,accessor new-struct) new-val)
45   - new-struct )))))))
  36 + (let ((accessor (intern (concatenate
  37 + 'string conc-name
  38 + (symbol-name (if (atom slot)
  39 + slot
  40 + (first slot) ))))))
  41 + (collecting
  42 + `(define-modf-function ,accessor 1 (new-val object)
  43 + (let ((new-struct (copy-structure object)))
  44 + (setf (,accessor new-struct) new-val)
  45 + new-struct )))))))
46 46
47 47 (defmacro define-modf-for-struct-slots (structure-definition-form)
  48 + "This macro defines Modf expanders for structure slots when given a structure
  49 +definition form."
48 50 `(eval-when (:compile-toplevel :load-toplevel :execute)
49 51 ,@(apply #'modf-for-struct-slots-expander structure-definition-form) ))
50 52
51 53 (defun group (source n)
52 54 (if (zerop n) (error "zero length"))
53 55 (labels ((rec (source acc)
54   - (let ((rest (nthcdr n source)))
55   - (if (consp rest)
56   - (rec rest (cons (subseq source 0 n) acc))
57   - (nreverse (cons source acc)) ))))
  56 + (let ((rest (nthcdr n source)))
  57 + (if (consp rest)
  58 + (rec rest (cons (subseq source 0 n) acc))
  59 + (nreverse (cons source acc)) ))))
58 60 (if source (rec source nil) nil) ))
59 61
60 62 (defun group-by (list &rest counts)
@@ -68,60 +70,95 @@
68 70 ;; slot they are associated with.
69 71 `(progn
70 72 (cl:defclass ,name ,direct-superclasses ,direct-slots ,@options)
71   - ,@(iter :outer
72   - (for slot in direct-slots)
73   - (let ((slot-name (if (atom slot) slot (first slot))))
74   - (iter (for accessor in (remove-if-not
75   - (lambda (x) (member
76   - (first x)
77   - '(:accessor :reader) ))
78   - (group-by (rest slot) 2) ))
79   - (in :outer
80   - (collecting
81   - `(define-modf-method ,(second accessor) 1
82   - (new-val (obj ,name))
83   - (modf (slot-value obj ',slot-name) new-val) ))))))))
  73 + ,@(iter :outer
  74 + (for slot in direct-slots)
  75 + (let ((slot-name (if (atom slot) slot (first slot))))
  76 + (iter (for accessor in (remove-if-not
  77 + (lambda (x) (member
  78 + (first x)
  79 + '(:accessor :reader) ))
  80 + (group-by (rest slot) 2) ))
  81 + (in :outer
  82 + (collecting
  83 + `(define-modf-method ,(second accessor) 1
  84 + (new-val (obj ,name))
  85 + (modf (slot-value obj ',slot-name) new-val) ))))))))
  86 +
  87 +(defun get-modf-reader-definitions (class &optional (defined-readers nil))
  88 + #+closer-mop
  89 + (let ((class (find-class class)))
  90 + (unless (closer-mop:class-finalized-p class)
  91 + (error "Class ~S not finalized." class) )
  92 + #+ecl
  93 + ;; ECL seems to work a bit more intuitively. Effective slots know their
  94 + ;; readers.
  95 + (let* ((slots (closer-mop:class-slots class)))
  96 + (iter :outer
  97 + (for slot in slots)
  98 + (iter (for reader in (closer-mop:slot-definition-readers slot))
  99 + (in :outer
  100 + (unless (member reader defined-readers)
  101 + (collecting
  102 + `(define-modf-method ,reader 1 (new-val (obj ,(class-name class)))
  103 + (modf (slot-value
  104 + obj ',(closer-mop:slot-definition-name slot) )
  105 + new-val ))))))))
  106 + #-ecl
  107 + (let* ((slot-groups (mapcar #'closer-mop:class-direct-slots
  108 + (closer-mop:class-precedence-list class) ))
  109 + (defined-readers defined-readers) )
  110 + (iter :outer
  111 + (for slots in slot-groups)
  112 + (iter
  113 + (for slot in slots)
  114 + (iter (for reader in (closer-mop:slot-definition-readers slot))
  115 + (in :outer
  116 + ;; We need an extra check to make sure we don't clobber
  117 + ;; reader functions that are overridden from the ancestor
  118 + ;; classes
  119 + (unless (member reader defined-readers)
  120 + (push reader defined-readers)
  121 + (collecting
  122 + `(define-modf-method ,reader 1 (new-val (obj ,(class-name class)))
  123 + (modf
  124 + (slot-value
  125 + obj ',(closer-mop:slot-definition-name slot) )
  126 + new-val )))))))))))
84 127
85 128 (defun modf-for-class-slots-expander (class)
86   - ;; We need the names of all methods that access data in the object and what
87   - ;; slot they are associated with.
88 129 (if (consp class)
89 130 ;; This is a definition form
90 131 (destructuring-bind (defclass name direct-superclasses direct-slots &rest options)
91 132 class
92   - (declare (ignore defclass direct-superclasses options))
93   - (iter :outer
94   - (for slot in direct-slots)
95   - (let ((slot-name (if (atom slot) slot (first slot))))
96   - (iter (for accessor in (remove-if-not
97   - (lambda (x) (member
98   - (first x)
99   - '(:accessor :reader) ))
100   - (group-by (rest slot) 2) ))
101   - (in :outer
102   - (collecting
103   - `(define-modf-method ,(second accessor) 1
104   - (new-val (obj ,name))
105   - (modf (slot-value obj ',slot-name) new-val) )))))))
  133 + (declare (ignore defclass options))
  134 + (let ((defined-readers nil))
  135 + (apply
  136 + #'append
  137 + (iter :outer
  138 + (for slot in direct-slots)
  139 + (let ((slot-name (if (atom slot) slot (first slot))))
  140 + (iter (for accessor in (remove-if-not
  141 + (lambda (x) (member
  142 + (first x)
  143 + '(:accessor :reader) ))
  144 + (group-by (rest slot) 2) ))
  145 + (in :outer
  146 + (push accessor defined-readers)
  147 + (collecting
  148 + `(define-modf-method ,(second accessor) 1
  149 + (new-val (obj ,name))
  150 + (modf (slot-value obj ',slot-name) new-val) ))))))
  151 + ;; Then we handle the parent (if Closer-Mop is loaded). This is a bit
  152 + ;; messy. What about the proper precedence list?
  153 + (mapcar #'get-modf-reader-definitions direct-superclasses
  154 + defined-readers ))))
106 155 ;; This must be a class object or name
107   - ;; I actually don't this this works quite right, but whatever.
108   - #+closer-mop
109   - (let ((class (find-class class)))
110   - (unless (closer-mop:class-finalized-p class)
111   - (error "Class ~S not finalized." class) )
112   - (iter
113   - :outer
114   - (for slot in (closer-mop:class-direct-slots class))
115   - (iter (for reader in (closer-mop:slot-definition-readers slot))
116   - (in :outer
117   - (collecting
118   - `(define-modf-method ,reader 1
119   - (new-val (obj ,class))
120   - (modf (slot-value obj ',(closer-mop:slot-definition-name
121   - slot ))
122   - new-val) ))))))))
  156 + (get-modf-reader-definitions class) ))
123 157
124 158 (defmacro define-modf-for-class-slots (class-name-or-definition)
  159 + "This macro defines Modf expanders for a class. We can do this given the
  160 +definition form for the class \(much like with DEFINE-MODF-FOR-STRUCT-SLOTS) or
  161 +the a name of a finalized class."
125 162 `(eval-when (:compile-toplevel :load-toplevel :execute)
126 163 ,@(modf-for-class-slots-expander class-name-or-definition) ))
127 164

0 comments on commit 576260e

Please sign in to comment.
Something went wrong with that request. Please try again.