| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Integrating classes into the C type system |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 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) |
| 33 | ((%class :initarg :class :initform nil |
| 34 | :type (or null sod-class) :accessor c-type-class) |
| 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 | |
| 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.")) |
| 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) |
| 60 | "Look up NAME and return the corresponding `c-class-type'. |
| 61 | |
| 62 | * If the type was found, and was a class, returns TYPE. |
| 63 | |
| 64 | * If no type was found at all, returns `nil'. |
| 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) |
| 71 | (t (error "Type `~A' is not a class" name)))) |
| 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 |
| 84 | ;; they're different -- and we use the tag as part of the input to |
| 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))) |
| 94 | (setf (gethash name *module-type-map*) type) |
| 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) |
| 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)) |
| 136 | (t |
| 137 | (error "Type `~A' not known" name)))) |
| 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 -------------------------------------------------- |