3 ;;; Integrating classes into the C type system
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (export '(c-class-type c-type-class))
32 (defclass c-class-type (simple-c-type)
33 ((%class :initarg :class :initform nil
34 :type (or null sod-class) :accessor c-type-class)
37 "A SOD class, as a C type.
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
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.
48 The NAME slot inherited from `simple-c-type' is here so that we can print
49 the type even when it's a forward reference."))
51 ;; Constructor function and interning.
53 (define-module-var *module-type-map* (make-hash-table :test #'equal)
54 "Table mapping identifiers to C type objects.
56 Each module has its own map.")
58 (export 'find-class-type)
59 (defun find-class-type (name)
60 "Look up NAME and return the corresponding `c-class-type'.
62 * If the type was found, and was a class, returns TYPE.
64 * If no type was found at all, returns `nil'.
66 * If a type was found, but it wasn't a class, signals an error."
68 (atypecase (gethash name *module-type-map*)
71 (t (error "Type `~A' is not a class" name))))
73 (export 'make-class-type)
74 (defun make-class-type (name &optional qualifiers)
75 "Make a distinguished object for the class type called NAME."
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.
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
84 ;; they're different -- and we use the tag as part of the input to
87 ;; So the first thing to do is to find the tag for the basic type, without
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)))
94 (setf (gethash name *module-type-map*) type)
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
100 (if (null qualifiers)
102 (intern-c-type 'c-class-type
104 :qualifiers (canonify-qualifiers qualifiers)))))
106 ;; Comparison protocol.
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)))
112 ;; S-expression notation protocol.
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~}~:>"
118 (c-type-qualifiers type)))
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)))
125 ;;;--------------------------------------------------------------------------
126 ;;; Additional functions for lookup.
128 (export 'find-sod-class)
129 (defun find-sod-class (name)
130 "Return the `sod-class' object with the given NAME."
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))
137 (error "Type `~A' not known" name))))
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)))))
150 ;;;----- That's all, folks --------------------------------------------------