;;; -*-lisp-*-
;;;
;;; Integrating classes into the C type system
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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)))
	     (setf (gethash name *module-type-map*) type)
	     (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 --------------------------------------------------