Added define-association.
[com-informatimago:com-informatimago.git] / clext / association.lisp
1 ;;;;  -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;; FILE:               metamodel-macros.lisp
4 ;;;; LANGUAGE:           Common-Lisp
5 ;;;; SYSTEM:             Common-Lisp
6 ;;;; USER-INTERFACE:     NONE
7 ;;;; DESCRIPTION
8 ;;;;     
9 ;;;;     Macros definitions for the objecteering metamodel.
10 ;;;;     
11 ;;;; AUTHORS
12 ;;;;     <PJB> Pascal J. Bourguignon <pjb@anevia.com>
13 ;;;; MODIFICATIONS
14 ;;;;     2009-05-20 <PJB> Adapted these macros for the objecteering metamodel.
15 ;;;;     2009-01-09 <PJB> Added this comment.
16 ;;;; BUGS
17 ;;;; LEGAL
18 ;;;;     GPL
19 ;;;;     
20 ;;;;     Copyright 
21 ;;;;     
22 ;;;;     This program is free software; you can redistribute it and/or
23 ;;;;     modify it under the terms of the GNU General Public License
24 ;;;;     as published by the Free Software Foundation; either version
25 ;;;;     2 of the License, or (at your option) any later version.
26 ;;;;     
27 ;;;;     This program is distributed in the hope that it will be
28 ;;;;     useful, but WITHOUT ANY WARRANTY; without even the implied
29 ;;;;     warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
30 ;;;;     PURPOSE.  See the GNU General Public License for more details.
31 ;;;;     
32 ;;;;     You should have received a copy of the GNU General Public
33 ;;;;     License along with this program; if not, write to the Free
34 ;;;;     Software Foundation, Inc., 59 Temple Place, Suite 330,
35 ;;;;     Boston, MA 02111-1307 USA
36 ;;;; *************************************************************************
37
38 (defpackage "COM.INFORMATIMAGO.CLEXT.ASSOCIATION"
39   (:use "COMMON-LISP" "CLOSER-MOP")
40   (:shadowing-import-from "CLOSER-MOP"
41                           "STANDARD-CLASS" "STANDARD-GENERIC-FUNCTION" "STANDARD-METHOD"
42                           "DEFMETHOD" "DEFGENERIC")
43   (:export "DEFINE-CLASS" "DEFINE-ASSOCIATION" "CHECK-OBJECT" "CHECK-CHAIN"))
44 (in-package "COM.INFORMATIMAGO.CLEXT.ASSOCIATION")
45
46
47
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 ;;;
50 ;;; CLASSES
51 ;;;
52
53 (defmacro define-class (class-name superclasses &key slots documentation)
54   "
55 DO:     Define a class, with a slightly different syntax.
56         Since there are a lot of classes with no additionnal slots,
57         to make the slots optional, we introduce them with a :slots keyword.
58         The initarg and accessor are automatically generated with the same
59         name as the slot by default.
60         The initform is automatically set to nil by default.
61 "
62   `(progn
63      (defclass ,class-name ,superclasses
64       ,(mapcar
65         (lambda (slot)
66           (if (atom slot)
67               `(,slot
68                 :initarg ,(intern (string slot) "KEYWORD")
69                 :initform 'nil
70                 :accessor ,slot)
71               (destructuring-bind (slot-name &key initarg initform type accessor documentation) slot
72                 `(,slot-name
73                   :initarg ,(or initarg
74                                 (intern (string slot-name) "KEYWORD"))
75                   :initform ,(or initform 'nil)
76                   :accessor ,(or accessor slot-name)
77                   ,@(when documentation (list :documentation documentation))
78                   ,@(when type (list :type type))))))
79         slots)
80       ,@(when documentation `((:documentation ,documentation))))
81      ',class-name))
82
83
84
85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
86 ;;;
87 ;;; ASSOCIATIONS
88 ;;;
89 ;;; This kind of association will modify the class of the objects they
90 ;;; associate, adding the needed slots.
91 ;;;
92
93 (eval-when (:load-toplevel :compile-toplevel :execute)
94
95   (defun variations (item list)
96     (if (null list)
97         (list (list item))
98         (cons (cons item list)
99               (mapcar (lambda (rest) (cons (car list) rest))
100                       (variations item (cdr list))))))
101
102   (defun permutations (elements)
103     (cond
104       ((null elements) (list elements))
105       ((null (cdr elements)) (list elements))
106       (t (mapcan (lambda (subperm) (variations (car elements) subperm))
107                  (permutations (cdr elements))))))
108
109
110   (defun multiplicity (multiplicity)
111     "
112 DO:            Decodes the multiplicity.
113 MULTIPLICITY:  may be either an integer,  or a string designator
114                the form  \"*\"or \"MIN-MAX\" or \"MIN..MAX\".
115                (beware that the token 0..1 is a 'potential number').
116 RETURN:        MIN; MAX"
117     (multiple-value-bind (min max)
118         (if (integerp multiplicity)
119             (values multiplicity multiplicity)
120             (let* ((smul   (string multiplicity))
121                    (dash   (position #\- smul))
122                    (dotdot (search ".." smul))
123                    (*read-eval* nil)
124                    (*read-base* 10.))
125               (cond
126                 (dash
127                  (values  (read-from-string smul t nil :end dash)
128                           (read-from-string smul t nil :start (1+ dash))))
129                 (dotdot
130                  (values  (read-from-string smul t nil :end dotdot)
131                           (read-from-string smul t nil :start (+ 2 dotdot))))
132                 (t
133                  (let ((star (read-from-string smul)))
134                    (if (eq '* star)
135                        (values 0 '*)
136                        (error "Missing a '-' or '..' in the multiplicity: ~A"
137                               multiplicity)))))))
138       ;; (print (list min max  (and (integerp min)  (not (minusp min))
139       ;;                            (or (eq max '*)
140       ;;                                (and (integerp max) (<= min max))))))
141       (assert (and (integerp min)  (not (minusp min))
142                    (or (eq max '*)
143                        (and (integerp max) (<= min max))))
144               (min max) "Invalid multiplicity ~A" multiplicity)
145       (values min max)))
146
147   
148   (defun test/multiplicity ()
149     (assert (equal (mapcar (lambda (test) (multiple-value-list (multiplicity test)))
150                            '(0    1    2    3
151                              0-1  1-1  0-4  2-4
152                              *    0-*  1-*  4-* ; 34-2
153                              0..1 1..1 0..4 2..4
154                              *    0..* 1..* 4..* ; 34..2
155                              ))
156                    '((0 0) (1 1) (2 2) (3 3)
157                      (0 1) (1 1) (0 4) (2 4)
158                      (0 *) (0 *) (1 *) (4 *) ; (34 2)
159                      (0 1) (1 1) (0 4) (2 4)
160                      (0 *) (0 *) (1 *) (4 *) ; (34 2)
161                      ))))
162   
163
164   (defun xor   (a b) (if a (not b) b))
165   (defun imply (p q) (or (not p) q))
166
167
168   (defun generate-link-parameters (endpoints)
169     (mapcar (function first) endpoints))
170
171   (defun generate-link-arguments (endpoints)
172     (let ((keyword (find-package "KEYWORD")))
173       (mapcan (lambda (endpoint)
174                 (destructuring-bind (role &key &allow-other-keys) endpoint
175                   (list (intern (string role) keyword) role)))
176               endpoints)))
177
178   (defun generate-attach-parameters (endpoints)
179     (mapcar (lambda (endpoint)
180               (destructuring-bind (role &key type accessor slot
181                                         &allow-other-keys) endpoint
182                 (assert (not (and accessor slot)) (accessor slot)
183                         "ACCESSOR and SLOT are mutually exclusive.")
184                 (list role type)))
185             endpoints))
186
187
188   ;; 0
189   ;; 1
190   ;; n
191   ;; 0..1
192   ;; 0..n
193   ;; 1..1
194   ;; n..m
195   ;; 0..* 
196   ;; 1..*
197   ;; n..*
198   ;; 
199   ;;                                        n-1     n-m,1<m
200   ;; set             o           (k o)       
201   ;; add             o           (k o)
202   ;; remove          o              o
203   ;; contains        o              o
204   ;; get             x             x
205   ;; size            x             x
206   ;; clear           x             x 
207   ;; remove-key                   k
208   ;; contains-key                 k
209   ;;
210   ;; (a . role . set b)            (asso-link a b)           (b . role . set a)
211   ;; (a . role . add b)            (asso-link a b)           (b . role . add a)
212   ;; (a . role . remove b)         (asso-unlink a b)         (b . role . remove a)
213   ;; (a . role . contains b)       (asso-contains-p a b)     (b . role . contains a)
214   ;; (a . role . get) -> b                =/=                (b . role . get) -> a
215   ;; (a . role . size) -> n1   =/= (asso-size)           =/= (b . role . size) -> n2  
216   ;; (a . role . clear)        =/= (asso-clear)          =/= (b . role . clear)       
217   ;; (a . role . remove-key k1)           =/=                (b . role . remove-key k2)
218   ;; (a . role . contains-key k1)         =/=                (b . role . contains-key k2)
219   ;; (a . role . add  k1 b)    =/= (asso-link k2 a k1 b) =/= (b . role . add k2 b)
220   ;; (a . role . add  k1 b)    =/= (asso-link k2 a k1 b) =/= (b . role . add k2 b)
221   ;;
222   ;; Currently implemented:
223   ;; ASSO-LINK, ASSO-UNLINK, ASSO-CONTAINS-P
224   ;; GET and SIZE are implemented by using directly the accessor for the role
225
226   (defun generate-single-setter (accessor slot copier object value)
227     (if accessor
228         `(setf (,accessor ,object)         (,copier ,value))
229         `(setf (slot-value ,object ',slot) (,copier ,value))))
230
231   (defun generate-multi-adder (accessor slot copier test object value)
232     `(pushnew (funcall ,copier ,value)
233               (if accessor
234                   (,accessor ,object)
235                   (slot-value ,object ',slot))
236               :test ,test))
237
238   (defun generate-getter (accessor slot copier object value)
239     (if (eq copier 'identity)
240         (if accessor
241             `(,accessor ,object)
242             `(slot-value ,object ',slot))
243         `(,copier ,(if accessor
244                        `(,accessor ,object)
245                        `(slot-value ,object ',slot)))))
246
247
248   (defgeneric did-link    (association-name left right)
249     (:documentation
250      "Hook called after a new link for the association is created between LEFT and RIGHT.")
251     (:method (association-name (left t) (right t)) (values)))
252
253   (defgeneric will-unlink (association-name left right)
254     (:documentation
255      "Hook called before an old link for the association is removed between LEFT and RIGHT.")
256     (:method (association-name (left t) (right t)) (values)))
257
258
259   (defun generate-addset (association-name value object this)
260     (destructuring-bind (this-role &key
261                                    ((:slot this-slot))
262                                    ((:accessor this-accessor))
263                                    ((:multiplicity this-multiplicity))
264                                    ((:implementation this-implementation))
265                                    ((:test this-test) '(function eql))
266                                    ((:copy this-copy) '(function identity))
267                                    &allow-other-keys) this
268       (multiple-value-bind (this-min this-max) (multiplicity this-multiplicity)
269         (let ((this-implementation (or this-implementation
270                                        (if (equal 1 this-max) 'reference 'list))))
271           (assert (member this-implementation  '(list reference))
272                   (this-implementation)
273                   "IMPLEMENTATION other than REFERENCE or LIST are ~
274                    not implemented yet.")
275           (assert (imply (eq this-implementation 'reference) (equal 1 this-max))
276                   (this-implementation this-max)
277                   "THIS-IMPLEMENTATION must be LIST when THIS-MAX is not 1")
278           (flet ((slot  () (if this-accessor
279                                `(,this-accessor ,object)
280                                `(slot-value ,object ',this-slot)))
281                  (value () (if (or (equal '(function identity) this-copy)
282                                    (eq 'identity this-copy))
283                                value
284                                `(,this-copy  ,value))))
285             ;; 0-1   link          reference   (setf as (copy o))
286             ;; 1-1   link          reference   (setf as (copy o))
287             ;;
288             ;; n-m   link          list        (if (and (< (length as) m) (not (containsp o as)))  (push o as) (error "full"))
289             ;; 0-*   link          list        (pushnew o as :test test)
290             ;; 1-*   link          list        (pushnew o as :test test)
291             ;; n-*   link          list        (pushnew o as :test test)
292             ;; 0-1   link          list        (setf as (list (copy o)))
293             ;; 1-1   link          list        (setf as (list (copy o)))
294             (ecase this-implementation
295               ((reference)
296                `(progn (assert (null ,(slot)))
297                        (setf ,(slot) ,(value))))
298               ((list)
299                (cond
300                  ((eql  1 this-max)
301                   `(progn (assert (null ,(slot)))
302                           (setf ,(slot) (list ,(value)))))
303                  ((eql '* this-max)
304                   `(progn (assert (not (member ,value ,(slot) :test ,this-test)))
305                           (pushnew ,(value) ,(slot) :test ,this-test)))
306                  (t
307                   (let ((vendpoint (gensym)))
308                     `(let ((,vendpoint  ,(slot)))
309                        (if (and (<  (length ,vendpoint) ,this-max)
310                                 (not (member ,value ,vendpoint :test ,this-test)))
311                            (progn (assert (not (member ,value ,(slot) :test ,this-test)))
312                                   (push ,(value) ,(slot)))
313                            (cerror "Endpoint ~A of association ~A is full, maximum multiplicity is ~A is reached."
314                                    ',this-role ',association-name ',this-max)))))))))))))
315
316   
317   (defun generate-remove (association-name value object this)
318     (destructuring-bind (this-role &key
319                                    ((:slot this-slot))
320                                    ((:accessor this-accessor))
321                                    ((:multiplicity this-multiplicity))
322                                    ((:implementation this-implementation))
323                                    ((:test this-test) '(function eql))
324                                    ((:copy this-copy) '(function identity))
325                                    &allow-other-keys) this
326       (multiple-value-bind (this-min this-max) (multiplicity this-multiplicity)
327         (let ((this-implementation (or this-implementation
328                                        (if (equal 1 this-max) 'reference 'list))))
329           (assert (member this-implementation  '(list reference))
330                   (this-implementation)
331                   "IMPLEMENTATION other than REFERENCE or LIST ~
332                    are not implemented yet.")
333           (assert (imply (eq this-implementation  'reference) (equal 1 this-max))
334                   (this-implementation this-max)
335                   "THIS-IMPLEMENTATION must be LIST when THIS-MAX is not 1")
336           (flet ((slot  () (if this-accessor
337                                `(,this-accessor ,object)
338                                `(slot-value ,object ',this-slot)))
339                  (value () (if (or (equal '(function identity) this-copy)
340                                    (eq 'identity this-copy))
341                                value
342                                `(,this-copy  ,value))))
343             ;; 1-1   unlink        reference   (error)    
344             ;; 0-1   unlink        reference   (setf as nil)
345             ;;
346             ;; 1-*   unlink        list        (if (< 1 (length as)) (setf as (delete o as :test test)) (error))
347             ;; 1-1   unlink        list        (if (< 1 (length as)) (setf as (delete o as :test test)) (error))
348             ;; n-*   unlink        list        (if (< n (length as)) (setf as (delete o as :test test)) (error))
349             ;; n-m   unlink        list        (if (< n (length as)) (setf as (delete o as :test test)) (error))
350             ;; 0-*   unlink        list        (setf as (delete o as :test test))
351             ;; 0-1   unlink        list        (setf as (delete o as :test test))
352             (ecase this-implementation
353               ((reference)
354                `(when (funcall ,this-test ,value ,(slot))
355                   ,(if (eql 1 this-min)
356                        `(error "Cannot remove the only ~A from the ~
357                                 association ~A of minimum multiplicity ~A."
358                                ',this-role ',association-name ',this-min)
359                        `(setf ,(slot) nil))))
360               ((list)
361                (let ((vendpoint (gensym)))
362                  `(let ((,vendpoint ,(slot)))
363                     (when (member ,value ,vendpoint :test ,this-test)
364                       ,(if (zerop this-min)
365                            `(setf ,(slot) (delete ,value ,vendpoint
366                                                   :test ,this-test :count 1))
367                            `(if  (< ,this-min (length ,vendpoint))
368                                  (setf ,(slot) (delete ,value ,vendpoint
369                                                        :test ,this-test :count 1))
370                                  (error "The role ~A of the association ~A ~
371                                          has reached its minimum multiplicity ~A."
372                                         ',this-role ',association-name
373                                         ',this-min)))))))))))))
374
375   
376   (defun generate-contains-p (association-name value object this)
377     (destructuring-bind (this-role &key
378                                    ((:slot this-slot))
379                                    ((:accessor this-accessor))
380                                    ((:multiplicity this-multiplicity))
381                                    ((:implementation this-implementation))
382                                    ((:test this-test) '(function eql))
383                                    ((:copy this-copy) '(function identity))
384                                    &allow-other-keys) this
385       (multiple-value-bind (this-min this-max) (multiplicity this-multiplicity)
386         (let ((this-implementation (or this-implementation
387                                        (if (equal 1 this-max) 'reference 'list))))
388           (assert (member this-implementation  '(list reference))
389                   (this-implementation)
390                   "IMPLEMENTATION other than REFERENCE or LIST ~
391                    are not implemented yet.")
392           (assert (imply (eq this-implementation  'reference) (equal 1 this-max))
393                   (this-implementation this-max)
394                   "THIS-IMPLEMENTATION must be LIST when THIS-MAX is not 1")
395           (flet ((slot  () (if this-accessor
396                                `(,this-accessor ,object)
397                                `(slot-value ,object ',this-slot)))
398                  (value () (if (or (equal '(function identity) this-copy)
399                                    (eq 'identity this-copy))
400                                value
401                                `(,this-copy  ,value))))
402             ;; 0-1   containsp     reference   (test as o)
403             ;; 1-1   containsp     reference   (test as o)
404             ;;
405             ;; 0-*   containsp     list        (find o as :test test)
406             ;; 0-1   containsp     list        (find o as :test test)
407             ;; 1-*   containsp     list        (find o as :test test)
408             ;; 1-1   containsp     list        (find o as :test test)
409             ;; n-*   containsp     list        (find o as :test test)
410             ;; n-m   containsp     list        (find o as :test test)
411             (ecase this-implementation
412               ((reference) `(funcall ,this-test ,value ,(slot)))
413               ((list)      `(member ,value ,(slot) :test ,this-test))))))))
414
415   '#:eval-when/functions-for-macro)
416
417
418 (eval-when (:execute)
419   (test/multiplicity)
420   'tests) ;; eval-when
421
422
423 (defun convert-to-direct-slot-definition (class canonicalized-slot)
424   (apply (function make-instance)
425          (apply (function closer-mop:direct-slot-definition-class) class canonicalized-slot)
426          canonicalized-slot))
427
428
429 (defun canonicalize-slot-definition (slotdef)
430   (list :name         (closer-mop:slot-definition-name         slotdef)
431         :readers      (closer-mop:slot-definition-readers      slotdef)
432         :writers      (closer-mop:slot-definition-writers      slotdef)
433         :type         (closer-mop:slot-definition-type         slotdef)
434         :allocation   (closer-mop:slot-definition-allocation   slotdef)
435         :initargs     (closer-mop:slot-definition-initargs     slotdef)
436         :initform     (closer-mop:slot-definition-initform     slotdef)
437         :initfunction (closer-mop:slot-definition-initfunction slotdef)))
438
439
440 (defun ensure-class-slot (class-name slot-name)
441   (let ((class (find-class class-name)))
442     (when class
443       ;; finalize it before calling CLOSER-MOP:CLASS-SLOTS
444       (make-instance class-name)
445       (unless (find slot-name (closer-mop:class-slots class)
446                     :key (function closer-mop:slot-definition-name))
447         (closer-mop:ensure-class
448          class-name
449          :direct-slots
450          (append (mapcar (function canonicalize-slot-definition) (closer-mop:class-direct-slots class))
451                  (list (list  :name slot-name
452                               :initform 'nil
453                               :initfunction (constantly nil)
454                               :initargs (list (intern (string slot-name) "KEYWORD"))
455                               :readers  (list slot-name)
456                               :writers  (list `(setf ,slot-name))
457                               :documentation  "Generated by define-association"))))))
458     class))
459
460
461 (defmacro define-association (name endpoints &rest options)
462   "
463 Define functions to manage the association:
464     (name-LINK       a b ...)
465     (name-UNLINK     a b ...)
466     (name-CONTAINS-P a b ...) --> BOOLEAN
467     (name-SIZE)  --> INTEGER
468     (name-CLEAR) --> INTEGER
469 taking &KEY arguments named for the ROLE names.
470 There may be more than two endpoints, in case of ternary, etc associations.
471
472 ENDPOINTS      a list of (ROLE &KEY TYPE ACCESSOR SLOT MULTIPLICITY MULTIPLE
473                           IMPLEMENTATION COPY TEST).
474
475
476 TYPE           needed for ATTACH and DETACH.
477                If all the types are present and different, then ATTACH and
478                DETACH methods are created for the arguments in any order.
479
480     Note: we should review this macro for TYPE vs.CLASS.
481           Slots may be accessed only in instances of standard-class classes.
482           Accessors may be used with any type.
483
484 ACCESSOR and SLOT are optional, and mutually exclusive.
485
486    --------  ---------  ----------  -------------  -------  ------  --------
487    ACCESSOR    SLOT     Slot        Accessor       CreSlot  CreAcc  Use
488    --------  ---------  ----------  -------------  -------  ------  --------
489     absent    absent    Role name   Role Name       Yes      Yes     slot
490                         When both :accessor and :slot are absent, the role
491                         name is used to create a slot with an accessor in
492                         the associated class. 
493                         Note: In this case, :type must be given a class.
494    --------  ---------  ----------  -------------  -------  ------  --------
495     absent    present   Given slot     N/A           No       No     slot
496
497                         The associated class is not changed.  The given slot
498                         is directly used.
499    --------  ---------  ----------  -------------  -------  ------  --------
500    present    absent        N/A     Given Accessor   No       No    accessor
501
502                         The associated class is not changed.  The given
503                         accessor is used.
504    --------  ---------  ----------  -------------  -------  ------  --------
505    present    present   ...................FORBIDDEN........................
506    --------  ---------  ----------  -------------  -------  ------  --------
507
508 MULTIPLICITY   may be either an integer, or a string designator the form \"MIN-MAX\"
509
510 MIN, MAX       an integer or * representing infinity; PRE: (< MIN MAX)
511
512 MULTIPLE       boolean default NIL indicates whether the same objects may be
513                in relation together several times.
514
515 COPY           if not nil, a function used to copy the objects before storing
516                or returning them.
517
518 TEST           default is (FUNCTION EQL), the function used to compare object
519                put in relation.
520    Note: If you set COPY, you will probably want to set TEST too (default is EQL).
521          For strings, you may want to set TEST to EQUAL or EQUALP
522          For numbers, you may want to set TEST to =, etc.
523          COPY and TEST are evaluated, so you can pass 'fun, (function fun)
524          or (lambda (x) (fun x)).
525
526 IMPLEMENTATION is (OR (MEMBER REFERENCE LIST VECTOR HASH-TABLE A-LIST P-LIST REIFIED)
527                       (CONS (HASH-TABLE A-LIST P-LIST)
528                             (CONS (MEMBER REFERENCE LIST VECTOR) NIL)))
529                indicates the kind of slot used to implement the role.
530     REFERENCE  only when (= 1 MAX) : the related object is stored in the slot.
531     LIST       the related objects are stored in a list.
532     VECTOR     the related objects are stored in a vector.
533                If MAX is finite, then the size of the vector must be = MAX
534                else the VECTOR must be adjustable and may have a fill-pointer.
535     A-LIST     the related keys and objects are stored in an a-list.
536                For qualified roles.
537     P-LIST     the related keys and objects are stored in a p-list.
538                For qualified roles.
539     HASH-TABLE the related keys and objects are stored in a HASH-TABLE.
540                For qualified roles.
541     REIFIED    the association is reified and nothing is stored in the
542                related objects.
543
544     For qualified roles, the multiplicity is per key.
545        (persons :multiplicity 0-* :implementation hash-table)
546        gives several persons per key (name -> homonyms).
547     In case of qualified roles and (< 1 MAX), the IMPLEMENTATION can be given
548     as a list of two items, the first giving the implementation of the role,
549     and the second the implementation of the values. (HASH-TABLE VECTOR) maps
550     with an hash-table keys to vectors of associated objects.
551
552     Currently implemented:  REFERENCE and LIST.
553     MULTIPLE is not implemented yet.
554
555 ORDERED        boolean indicating whether the objects are ordered in the containers
556                (only for REFERENCE, LIST, VECTOR and REIFIED).
557 OPTIONS        a list of (:keyword ...) options.
558    (:DOCUMENTATION string)
559
560 BUGS:    If there is an error in handling one association end, after
561          handling the other end, the state becomes invalid. No transaction :-(
562 "
563   (when (endp (rest endpoints))
564     (error "The association ~A needs at least two endpoints." name))
565   (assert (= 2 (length endpoints)) ()
566           "Sorry, associations with more than two endpoints such ~
567            as ~A are not implemented yet." name)
568   (let* ((link-parameters (generate-link-parameters endpoints))
569          (link-arguments  (generate-link-arguments  endpoints))
570          (types           (loop :for endpoint :in endpoints
571                              :for type = (getf (rest endpoint) :type)
572                              :when type :collect type))
573          (attachp         (= (length endpoints)
574                              (length (remove-duplicates types))))
575          (attach-args-permutations
576           (and attachp (permutations (generate-attach-parameters endpoints))))
577          (link            (intern (format nil "~A-LINK"   name)))
578          (unlink          (intern (format nil "~A-UNLINK" name)))
579          (contains-p      (intern (format nil "~A-CONTAINS-P" name))))
580
581     `(progn
582        ,@(loop
583             :with result = '()
584             :for endpoint :in endpoints
585             :do (destructuring-bind (this-role &key
586                                                ((:slot this-slot))
587                                                ((:accessor this-accessor))
588                                                ((:type this-type))
589                                                &allow-other-keys) endpoint
590                   (unless (or this-slot this-accessor)
591                     (assert this-type (this-type)
592                             "A :TYPE for the association end must be given ~
593                              when there's no :ACCESSOR or :SLOT.")
594                     (push `(ensure-class-slot ',this-type ',this-role) result)))
595             :finally (return result)) 
596        (defun ,link (&key ,@link-parameters)
597          ,(generate-addset name
598                            (first link-parameters) (second link-parameters)
599                            (first endpoints))
600          ,(generate-addset name
601                            (second link-parameters) (first link-parameters)
602                            (second endpoints))
603          (did-link  ',name ,(second link-parameters) ,(first link-parameters)))
604        (defun ,unlink (&key ,@link-parameters)
605          (multiple-value-prog1 (will-unlink  ',name
606                                              ,(second link-parameters)
607                                              ,(first link-parameters))
608            ,(generate-remove name
609                              (first link-parameters) (second link-parameters)
610                              (first endpoints))
611            ,(generate-remove name
612                              (second link-parameters) (first link-parameters)
613                              (second endpoints))))
614        (defun ,contains-p (&key ,@link-parameters)
615          (and ,(generate-contains-p name
616                                     (first link-parameters) (second link-parameters)
617                                     (first endpoints))
618               ,(generate-contains-p name
619                                     (second link-parameters) (first link-parameters)
620                                     (second endpoints))
621               t))
622        ,@ (when attachp
623             (let ((link-arguments
624                    (generate-link-arguments (first attach-args-permutations))))
625               (mapcar (lambda (arguments)
626                         (let ((arguments (cons `(asso (eql ',name)) arguments)))
627                           `(progn
628                              (defmethod attach      ,arguments
629                                (declare (ignore asso))
630                                (,link       ,@link-arguments))
631                              (defmethod detach      ,arguments
632                                (declare (ignore asso))
633                                (,unlink     ,@link-arguments))
634                              (defmethod associatedp ,arguments
635                                (declare (ignore asso))
636                                (,contains-p ,@link-arguments)))))
637                       attach-args-permutations)))
638        ',name)))
639
640
641
642 #-(and)
643 (let* ((class-name type))
644   
645   (let* ((class  (find-class class-name))
646          (slots  (mop:compute-slots class)))
647     (unless (find role slots :key (function mop:slot-description-name))
648       (mop:ensure-class
649        class-name
650        :direct-default-initargs (mop:class-direct-default-initargs class)
651        :direct-slots            (mop:class-direct-slots            class)
652        :direct-superclasses     (mop:class-direct-superclasses     class)
653        :name                    class-name
654        :metaclass               (class-of class)))))
655
656
657
658
659
660
661 (defmacro check-object (expression)
662   "Evaluates the expression and reports an error if it's NIL."
663   `(or ,expression (error  "~S returned NIL" ',expression)))
664
665
666 (defmacro check-chain (expression)
667   (flet ((chain-expression-p (expression)
668            "An expression that is a function call of a single other
669             chain-expression or a simple-expression."
670            ;; Actually, we only check the toplevel...
671            (and (listp expression)
672                 (= 2 (length expression))
673                 (consp (second expression)))))
674     (let ((vvalue (gensym)))
675       (if (chain-expression-p expression)
676           `(let ((,vvalue (check-chain ,(second expression))))
677              (or (,(first expression) ,vvalue)
678                  (error "~S returned NIL" ',expression)))
679           `(check-object ,expression)))))
680
681
682
683 ;;;; THE END ;;;;
684