X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bf090e021a5c20da452a4841cdfb8eb78e29544e..aa14a4cddcb96b681d5c19a2ec8bad382f43b264:/src/impl-c-types-class.lisp?ds=sidebyside diff --git a/src/impl-c-types-class.lisp b/src/impl-c-types-class.lisp deleted file mode 100644 index de980d8..0000000 --- a/src/impl-c-types-class.lisp +++ /dev/null @@ -1,145 +0,0 @@ -;;; -*-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 --------------------------------------------------