X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bf090e021a5c20da452a4841cdfb8eb78e29544e..aa14a4cddcb96b681d5c19a2ec8bad382f43b264:/src/c-types-class-impl.lisp diff --git a/src/c-types-class-impl.lisp b/src/c-types-class-impl.lisp new file mode 100644 index 0000000..de980d8 --- /dev/null +++ b/src/c-types-class-impl.lisp @@ -0,0 +1,145 @@ +;;; -*-lisp-*- +;;; +;;; Integrating classes into the C type system +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble Object Design, an object system for C. +;;; +;;; SOD is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; SOD is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with SOD; if not, write to the Free Software Foundation, +;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(cl:in-package #:sod) + +;;;-------------------------------------------------------------------------- +;;; Class definition. + +(export '(c-class-type c-type-class)) +(defclass c-class-type (simple-c-type) + ((class :initarg :class :initform nil + :type (or null sod-class) :accessor c-type-class) + (tag :initarg :tag)) + (:documentation + "A SOD class, as a C type. + + One usually handles classes as pointers, but the type refers to the actual + instance structure itself. Or, in fact, just the primary chain of the + instance (i.e., the one containing the class's own direct slots) -- which + is why dealing with the instance structure directly doesn't make much + sense. + + The CLASS slot will be NIL if the class isn't defined yet, i.e., this + entry was constructed by a forward reference operation. + + The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print + the type even when it's a forward reference.")) + +;; Constructor function and interning. + +(define-module-var *module-type-map* (make-hash-table :test #'equal) + "Table mapping identifiers to C type objects. + + Each module has its own map.") + +(export 'find-class-type) +(defun find-class-type (name) + "Look up NAME and return the corresponding C-CLASS-TYPE. + + * If the type was found, and was a class, returns TYPE. + + * If no type was found at all, returns NIL. + + * If a type was found, but it wasn't a class, signals an error." + + (atypecase (gethash name *module-type-map*) + (null nil) + (c-class-type it) + (t (error "Type `~A' (~A) is not a class" name it)))) + +(export 'make-class-type) +(defun make-class-type (name &optional qualifiers) + "Make a distinguished object for the class type called NAME." + + ;; We're in an awkward situation. We want to enter it into the + ;; `*c-type-intern-map*' so that it will handle the qualifiers list for + ;; us. But that map isn't scoped to particular modules, so we maintain our + ;; own `*module-type-map*'. But now we need to keep them in sync. + ;; + ;; The solution is to make the `*module-type-map*' be the master. Each + ;; class-type object has a tag -- a gensym, so that `equal' will think + ;; they're different -- and we use the tag as part of the input to + ;; `intern-c-type'. + ;; + ;; So the first thing to do is to find the tag for the basic type, without + ;; any qualifiers. + (multiple-value-bind (type tag) + (aif (find-class-type name) + (values it (slot-value it 'tag)) + (let* ((tag (gensym "TAG-")) + (type (intern-c-type 'c-class-type :name name :tag tag))) + (values type tag))) + + ;; If no qualifiers are wanted then we've already found or created the + ;; wanted type. Otherwise we'll intern another type with the right + ;; qualifiers. + (if (null qualifiers) + type + (intern-c-type 'c-class-type + :name name :tag tag + :qualifiers (canonify-qualifiers qualifiers))))) + +;; Comparison protocol. + +(defmethod c-type-equal-p and + ((type-a c-class-type) (type-b c-class-type)) + (eql (c-type-class type-a) (c-type-class type-b))) + +;; S-expression notation protocol. + +(defmethod print-c-type (stream (type c-class-type) &optional colon atsign) + (declare (ignore colon atsign)) + (format stream "~:@" + (c-type-name type) + (c-type-qualifiers type))) + +(export 'class) +(define-c-type-syntax class (name &rest quals) + "Returns a type object for the named class." + `(make-class-type ,name (list ,@quals))) + +;;;-------------------------------------------------------------------------- +;;; Additional functions for lookup. + +(export 'find-sod-class) +(defun find-sod-class (name) + "Return the SOD-CLASS object with the given NAME." + (aif (find-class-type name) + (or (c-type-class it) (error "Class `~A' is incomplete" name)) + (error "Type `~A' not known" name))) + +(export 'record-sod-class) +(defun record-sod-class (class) + "Record CLASS as being a class definition." + (with-default-error-location (class) + (let* ((name (sod-class-name class)) + (type (make-class-type name))) + (if (c-type-class type) + (cerror* "Class `~A' already defined at ~A" + name (file-location (c-type-class type))) + (setf (c-type-class type) class))))) + +;;;----- That's all, folks --------------------------------------------------