Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Equipment for building classes and friends | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Simple Object Definition system. | |
11 | ;;; | |
12 | ;;; SOD is free software; you can redistribute it and/or modify | |
13 | ;;; it under the terms of the GNU General Public License as published by | |
14 | ;;; the Free Software Foundation; either version 2 of the License, or | |
15 | ;;; (at your option) any later version. | |
16 | ;;; | |
17 | ;;; SOD is distributed in the hope that it will be useful, | |
18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 | ;;; GNU General Public License for more details. | |
21 | ;;; | |
22 | ;;; You should have received a copy of the GNU General Public License | |
23 | ;;; along with SOD; if not, write to the Free Software Foundation, | |
24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
25 | ||
26 | (cl:in-package #:sod) | |
27 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Finding things by name | |
30 | ||
31 | (defun find-superclass-by-nick (class nick) | |
32 | "Returns the superclass of CLASS with nickname NICK, or signals an error." | |
33 | ||
34 | ;; Slightly tricky. The class almost certainly hasn't been finalized, so | |
35 | ;; trundle through its superclasses and hope for the best. | |
36 | (if (string= nick (sod-class-nickname class)) | |
37 | class | |
38 | (or (some (lambda (super) | |
39 | (find nick (sod-class-precedence-list super) | |
40 | :key #'sod-class-nickname | |
41 | :test #'string=)) | |
42 | (sod-class-direct-superclasses class)) | |
43 | (error "No superclass of `~A' with nickname `~A'" class nick)))) | |
44 | ||
45 | (flet ((find-item-by-name (what class list name key) | |
46 | (or (find name list :key key :test #'string=) | |
47 | (error "No ~A in class `~A' with name `~A'" what class name)))) | |
48 | ||
49 | (defun find-instance-slot-by-name (class super-nick slot-name) | |
50 | (let ((super (find-superclass-by-nick class super-nick))) | |
51 | (find-item-by-name "slot" super (sod-class-slots super) | |
52 | slot-name #'sod-slot-name))) | |
53 | ||
54 | (defun find-class-slot-by-name (class super-nick slot-name) | |
55 | (let* ((meta (sod-class-metaclass class)) | |
56 | (super (find-superclass-by-nick meta super-nick))) | |
57 | (find-item-by-name "slot" super (sod-class-slots super) | |
58 | slot-name #'sod-slot-name))) | |
59 | ||
60 | (defun find-message-by-name (class super-nick message-name) | |
61 | (let ((super (find-superclass-by-nick class super-nick))) | |
62 | (find-item-by-name "message" super (sod-class-messages super) | |
63 | message-name #'sod-message-name)))) | |
64 | ||
65 | ;;;-------------------------------------------------------------------------- | |
66 | ;;; Class construction. | |
67 | ||
68 | (defun make-sod-class (name superclasses pset &optional location) | |
69 | "Construct and return a new SOD class with the given NAME and SUPERCLASSES. | |
70 | ||
71 | This is the main constructor function for classes. The protocol works as | |
72 | follows. The :LISP-CLASS property in PSET is checked: if it exists, it | |
73 | must be a symbol naming a (CLOS) class, which is used in place of | |
74 | SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further | |
75 | behaviour is left to the standard CLOS instance construction protocol; for | |
76 | example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE. | |
77 | ||
78 | Minimal sanity checking is done during class construction; most of it is | |
79 | left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS). | |
80 | ||
81 | Unused properties in PSET are diagnosed as errors." | |
82 | ||
83 | (with-default-error-location (location) | |
84 | (let ((class (make-instance (get-property pset :lisp-class :symbol | |
85 | 'sod-class) | |
86 | :name name | |
87 | :superclasses superclasses | |
88 | :location (file-location location) | |
89 | :pset pset))) | |
90 | (check-unused-properties pset) | |
91 | class))) | |
92 | ||
93 | (defgeneric guess-metaclass (class) | |
94 | (:documentation | |
95 | "Determine a suitable metaclass for the CLASS. | |
96 | ||
97 | The default behaviour is to choose the most specific metaclass of any of | |
98 | the direct superclasses of CLASS, or to signal an error if that failed.")) | |
99 | ||
100 | ;;;-------------------------------------------------------------------------- | |
101 | ;;; Slot construction. | |
102 | ||
103 | (defgeneric make-sod-slot (class name type pset &optional location) | |
104 | (:documentation | |
105 | "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. | |
106 | ||
107 | This is the main constructor function for slots. This is a generic | |
108 | function primarily so that the CLASS can intervene in the construction | |
109 | process. The default method uses the :LISP-CLASS property (defaulting to | |
110 | SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then | |
111 | constructed by MAKE-INSTANCE passing the arguments as initargs; further | |
112 | behaviour is left to the standard CLOS instance construction protocol; for | |
113 | example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE. | |
114 | ||
115 | Unused properties on PSET are diagnosed as errors.")) | |
116 | ||
117 | ;;;-------------------------------------------------------------------------- | |
118 | ;;; Slot initializer construction. | |
119 | ||
120 | ;;;-------------------------------------------------------------------------- | |
121 | ;;; Message construction. | |
122 | ||
123 | ;;;-------------------------------------------------------------------------- | |
124 | ;;; Method construction. | |
125 | ||
126 | ;;;-------------------------------------------------------------------------- | |
127 | ;;; Builder macros. | |
128 | ||
129 | ;;;----- That's all, folks -------------------------------------------------- |