+++ /dev/null
-;;; -*-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 "~:@<CLASS ~:@_~:I~S~{ ~_~S~}~:>"
- (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 --------------------------------------------------
~mdw / sod / blobdiff