chiark - git - mdw - sod/blob - src/c-types-class-impl.lisp

   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   (aif (find-class-type name)
 132        (or (c-type-class it) (error "Class `~A' is incomplete" name))
 133        (error "Type `~A' not known" name)))
 134
 135 (export 'record-sod-class)
 136 (defun record-sod-class (class)
 137   "Record CLASS as being a class definition."
 138   (with-default-error-location (class)
 139     (let* ((name (sod-class-name class))
 140            (type (make-class-type name)))
 141       (if (c-type-class type)
 142           (cerror* "Class `~A' already defined at ~A"
 143                    name (file-location (c-type-class type)))
 144           (setf (c-type-class type) class)))))
 145
 146 ;;;----- That's all, folks --------------------------------------------------