Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Integrating classes into the C type system | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
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 | ;;; Class definition. | |
30 | ||
31 | (export '(c-class-type c-type-class)) | |
32 | (defclass c-class-type (simple-c-type) | |
4b8e5c03 MW |
33 | ((%class :initarg :class :initform nil |
34 | :type (or null sod-class) :accessor c-type-class) | |
dea4d055 MW |
35 | (tag :initarg :tag)) |
36 | (:documentation | |
37 | "A SOD class, as a C type. | |
38 | ||
39 | One usually handles classes as pointers, but the type refers to the actual | |
40 | instance structure itself. Or, in fact, just the primary chain of the | |
41 | instance (i.e., the one containing the class's own direct slots) -- which | |
42 | is why dealing with the instance structure directly doesn't make much | |
43 | sense. | |
44 | ||
45 | The CLASS slot will be NIL if the class isn't defined yet, i.e., this | |
46 | entry was constructed by a forward reference operation. | |
47 | ||
3109662a | 48 | The NAME slot inherited from `simple-c-type' is here so that we can print |
dea4d055 MW |
49 | the type even when it's a forward reference.")) |
50 | ||
51 | ;; Constructor function and interning. | |
52 | ||
53 | (define-module-var *module-type-map* (make-hash-table :test #'equal) | |
54 | "Table mapping identifiers to C type objects. | |
55 | ||
56 | Each module has its own map.") | |
57 | ||
58 | (export 'find-class-type) | |
59 | (defun find-class-type (name) | |
3109662a | 60 | "Look up NAME and return the corresponding `c-class-type'. |
dea4d055 MW |
61 | |
62 | * If the type was found, and was a class, returns TYPE. | |
63 | ||
3109662a | 64 | * If no type was found at all, returns `nil'. |
dea4d055 MW |
65 | |
66 | * If a type was found, but it wasn't a class, signals an error." | |
67 | ||
68 | (atypecase (gethash name *module-type-map*) | |
69 | (null nil) | |
70 | (c-class-type it) | |
a52cb41c | 71 | (t (error "Type `~A' is not a class" name)))) |
dea4d055 MW |
72 | |
73 | (export 'make-class-type) | |
74 | (defun make-class-type (name &optional qualifiers) | |
75 | "Make a distinguished object for the class type called NAME." | |
76 | ||
77 | ;; We're in an awkward situation. We want to enter it into the | |
78 | ;; `*c-type-intern-map*' so that it will handle the qualifiers list for | |
79 | ;; us. But that map isn't scoped to particular modules, so we maintain our | |
80 | ;; own `*module-type-map*'. But now we need to keep them in sync. | |
81 | ;; | |
82 | ;; The solution is to make the `*module-type-map*' be the master. Each | |
83 | ;; class-type object has a tag -- a gensym, so that `equal' will think | |
bf090e02 | 84 | ;; they're different -- and we use the tag as part of the input to |
dea4d055 MW |
85 | ;; `intern-c-type'. |
86 | ;; | |
87 | ;; So the first thing to do is to find the tag for the basic type, without | |
88 | ;; any qualifiers. | |
89 | (multiple-value-bind (type tag) | |
90 | (aif (find-class-type name) | |
91 | (values it (slot-value it 'tag)) | |
92 | (let* ((tag (gensym "TAG-")) | |
93 | (type (intern-c-type 'c-class-type :name name :tag tag))) | |
9ec578d9 | 94 | (setf (gethash name *module-type-map*) type) |
dea4d055 MW |
95 | (values type tag))) |
96 | ||
97 | ;; If no qualifiers are wanted then we've already found or created the | |
98 | ;; wanted type. Otherwise we'll intern another type with the right | |
99 | ;; qualifiers. | |
100 | (if (null qualifiers) | |
101 | type | |
102 | (intern-c-type 'c-class-type | |
103 | :name name :tag tag | |
104 | :qualifiers (canonify-qualifiers qualifiers))))) | |
105 | ||
106 | ;; Comparison protocol. | |
107 | ||
108 | (defmethod c-type-equal-p and | |
109 | ((type-a c-class-type) (type-b c-class-type)) | |
110 | (eql (c-type-class type-a) (c-type-class type-b))) | |
111 | ||
112 | ;; S-expression notation protocol. | |
113 | ||
114 | (defmethod print-c-type (stream (type c-class-type) &optional colon atsign) | |
115 | (declare (ignore colon atsign)) | |
116 | (format stream "~:@<CLASS ~:@_~:I~S~{ ~_~S~}~:>" | |
117 | (c-type-name type) | |
118 | (c-type-qualifiers type))) | |
119 | ||
120 | (export 'class) | |
121 | (define-c-type-syntax class (name &rest quals) | |
122 | "Returns a type object for the named class." | |
123 | `(make-class-type ,name (list ,@quals))) | |
124 | ||
125 | ;;;-------------------------------------------------------------------------- | |
126 | ;;; Additional functions for lookup. | |
127 | ||
128 | (export 'find-sod-class) | |
129 | (defun find-sod-class (name) | |
3109662a | 130 | "Return the `sod-class' object with the given NAME." |
96d51a55 MW |
131 | (acond ((find-class-type name) |
132 | (or (c-type-class it) | |
133 | (error "Class `~A' is incomplete" name))) | |
134 | ((find-simple-c-type name) | |
135 | (error "Type `~A' is not a class" name)) | |
136 | (t | |
137 | (error "Type `~A' not known" name)))) | |
dea4d055 MW |
138 | |
139 | (export 'record-sod-class) | |
140 | (defun record-sod-class (class) | |
141 | "Record CLASS as being a class definition." | |
142 | (with-default-error-location (class) | |
143 | (let* ((name (sod-class-name class)) | |
144 | (type (make-class-type name))) | |
145 | (if (c-type-class type) | |
146 | (cerror* "Class `~A' already defined at ~A" | |
147 | name (file-location (c-type-class type))) | |
148 | (setf (c-type-class type) class))))) | |
149 | ||
150 | ;;;----- That's all, folks -------------------------------------------------- |