;;; -*-lisp-*-
;;;
;;; Builtin module provides the root of the class graph
;;;
;;; (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)

;;;--------------------------------------------------------------------------
;;; Infrastructure.

(defvar *class-slot-alist* nil)

(defun add-class-slot-function (name function)
  "Attach a slot function to the *class-slot-alist*.

   The FUNCTION is invoked with one argument, which is a `sod-class' object
   to which it should add a slot.  If a function with the same NAME is
   already defined then that function is replaced; otherwise a new name/
   function pair is defined.

   Functions are are invoked in the order in which their names were first
   added."

  (aif (assoc name *class-slot-alist* :test #'string=)
       (setf (cdr it) function)
       (asetf *class-slot-alist* (append it (list (cons name function))))))

(defmacro define-class-slot
    (name (class &optional stream) type init &body prepare)
  "Define a new class slot.

   The slot will be caled NAME, and will be of TYPE (which should be a type
   S-expression).  The slot's (static) initializer will be constructed by
   printing the value of INIT, which is evaluated with CLASS bound to the
   class object being constructed.  If any PREPARE forms are provided, then
   they are evaluated as a progn; they are evaluated with CLASS bound to the
   class object, and STREAM bound to the output stream it should write on."

  (with-gensyms (classvar)
    `(add-class-slot-function
      ',name
      (lambda (,classvar)
	(make-sod-slot ,classvar ,name (c-type ,type)
		       (make-property-set :lisp-class 'sod-class-slot
					  :initializer-function
					  (lambda (,class)
					    ,init)
					  ,@(and prepare
						 `(:prepare-function
						   (lambda (,class ,stream)
						     ,@prepare)))))))))

;;;--------------------------------------------------------------------------
;;; Basic information.

(define-class-slot "name" (class) const-string
  (prin1-to-string (sod-class-name class)))

(define-class-slot "nick" (class) const-string
  (prin1-to-string (sod-class-nickname class)))

;;;--------------------------------------------------------------------------
;;; Instance allocation and initialization.

(define-class-slot "initsz" (class) size-t
  (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))

(define-class-slot "imprint" (class stream)
    (* (fun (* void) ("/*p*/" (* void))))
  (format nil "~A__imprint" class)
  (let ((ilayout (sod-class-ilayout class)))
    (format stream "~&~:
/* Imprint raw memory with instance structure. */
static void *~A__imprint(void *p)
{
  struct ~A *sod__obj = p;

  ~:{sod__obj.~A.~A._vt = &~A;~:^~%  ~}
  return (p);
}~2%"
	    class
	    (ilayout-struct-tag class)
	    (mapcar (lambda (ichain)
		      (let* ((head (ichain-head ichain))
			     (tail (ichain-tail ichain)))
			(list (sod-class-nickname head)
			      (sod-class-nickname tail)
			      (vtable-name class head))))
		    (ilayout-ichains ilayout)))))

(define-class-slot "init" (class stream)
    (* (fun (* void) ("/*p*/" (* void))))
  (format nil "~A__init" class)

  ;; FIXME this needs a metaobject protocol
  (let ((ilayout (sod-class-ilayout class)))
    (format stream "~&~:
static void *~A__init(void *p)
{
  struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
	    class
	    (ilayout-struct-tag class))
    (dolist (ichain (ilayout-ichains ilayout))
      (let ((ich (format nil "sod__obj.~A.~A"
			 (sod-class-nickname (ichain-head ichain))
			 (sod-class-nickname (ichain-tail ichain)))))
	(dolist (item (ichain-body ichain))
	  (etypecase item
	    (vtable-pointer
	     nil)
	    (islots
	     (let ((isl (format nil "~A.~A"
				ich
				(sod-class-nickname (islots-class item)))))
	       (dolist (slot (islots-slots item))
		 (let ((dslot (effective-slot-direct-slot slot))
		       (init (effective-slot-initializer slot)))
		   (when init
		     (format stream "  ~A.~A =" isl
			     (sod-slot-name dslot))
		     (ecase (sod-initializer-value-kind init)
		       (:simple (write (sod-initializer-value-form init)
				       :stream stream
				       :pretty nil :escape nil)
				(format stream ";~%"))
		       (:compound (format stream " (~A) {"
					  (sod-slot-type dslot))
				  (write (sod-initializer-value-form init)
					 :stream stream
					 :pretty nil :escape nil)
				  (format stream "};~%"))))))))))))
    (format stream "~&~:
  return (p);
}~2%")))

;;;--------------------------------------------------------------------------
;;; Superclass structure.

(define-class-slot "n_supers" (class) size-t
  (length (sod-class-direct-superclasses class)))

(define-class-slot "supers" (class stream)
    (* (* (class "SodClass" :const) :const))
  (if (null (sod-class-direct-superclasses class)) 0
      (format nil "~A__supers" class))
  (let ((supers (sod-class-direct-superclasses class)))
    (when supers
      (format stream "~&~:
/* Direct superclasses. */
static const SodClass *const ~A__supers[] = {
  ~{~A__class~^,~%  ~}
};~2%"
	      class supers))))

(define-class-slot "n_cpl" (class) size-t
  (length (sod-class-precedence-list class)))

(define-class-slot "cpl" (class stream)
    (* (* (class "SodClass" :const) :const))
  (format nil "~A__cpl" class)
  (format stream "~&~:
/* Class precedence list. */
static const SodClass *const ~A__cpl[] = {
  ~{~A__class~^,~%  ~}
};~2%"
	  class (sod-class-precedence-list class)))

;;;--------------------------------------------------------------------------
;;; Chain structure.

(define-class-slot "link" (class) (* (class "SodClass" :const))
  (aif (sod-class-chain-link class)
       (format nil "~A__class" it)
       0))

(define-class-slot "head" (class) (* (class "SodClass" :const))
  (format nil "~A__class" (sod-class-chain-head class)))

(define-class-slot "level" (class) size-t
  (position class (reverse (sod-class-chain class))))

(define-class-slot "n_chains" (class) size-t
  (length (sod-class-chains class)))

(define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
  (format nil "~A__chains" class)
  (let ((chains (sod-class-chains class)))
    (format stream "~&~:
/* Chain structure. */
~1@*~:{static const SodClass *const ~A__chain_~A[] = {
  ~{~A__class~^,~%  ~}
};~:^~2%~}

~0@*static const struct sod_chain ~A__chains[] = {
~:{  { ~3@*~A,
    ~0@*&~A__chain_~A,
    ~4@*offsetof(struct ~A, ~A),
    (const struct sod_vtable *)&~A,
    sizeof(struct ~A) }~:^,~%~}
};~2%"
	    class			;0
	    (mapcar (lambda (chain)	;1
		      (let* ((head (sod-class-chain-head (car chain)))
			     (chain-nick (sod-class-nickname head)))
			(list class chain-nick			    ;0 1
			      (reverse chain)			    ;2
			      (length chain)			    ;3
			      (ilayout-struct-tag class) chain-nick ;4 5
			      (vtable-name class head)		    ;6
			      (ichain-struct-tag class head))))	    ;7
		    chains))))

;;;--------------------------------------------------------------------------
;;; Class-specific layout.

(define-class-slot "off_islots" (class) size-t
  (format nil "offsetof(struct ~A, ~A)"
	  (ichain-struct-tag class (sod-class-chain-head class))
	  (sod-class-nickname class)))

(define-class-slot "islotsz" (class) size-t
  (format nil "sizeof(struct ~A)"
	  (islots-struct-tag class)))

;;;--------------------------------------------------------------------------
;;; Bootstrapping the class graph.

(defun bootstrap-classes (module)
  (let* ((sod-object (make-sod-class "SodObject" nil
				     (make-property-set :nick 'obj)))
	 (sod-class (make-sod-class "SodClass" (list sod-object)
				    (make-property-set :nick 'cls)))
	 (classes (list sod-object sod-class)))

    ;; Sort out the recursion.
    (setf (slot-value sod-class 'chain-link) sod-object)
    (dolist (class classes)
      (setf (slot-value class 'metaclass) sod-class))

    ;; Predeclare the class types.
    (dolist (class classes)
      (make-class-type (sod-class-name class)))

    ;; Attach the class slots.
    (dolist (slot *class-slot-alist*)
      (funcall (cdr slot) sod-class))

    ;; These classes are too closely intertwined.  We must partially finalize
    ;; them together by hand.  This is cloned from `finalize-sod-class'.
    (dolist (class classes)
      (with-slots (class-precedence-list chain-head chain chains) class
	(setf class-precedence-list (compute-cpl class))
	(setf (values chain-head chain chains) (compute-chains class))))

    ;; Done.
    (dolist (class classes)
      (finalize-sod-class class)
      (add-to-module module class))))

(defun make-builtin-module ()
  (let ((module (make-instance 'module
			       :name (make-pathname :name "SOD-BASE"
						    :type "SOD"
						    :case :common)
			       :state nil))
	(include (format nil "#include \"~A\"~%"
			 (make-pathname :name "SOD" :type "H"
					:case :common))))
    (call-with-module-environment
     (lambda ()
       (dolist (name '("va_list" "size_t" "ptrdiff_t"))
	 (add-to-module module (make-instance 'type-item :name name)))
       (add-to-module module (make-instance 'code-fragment-item
					    :reason :c
					    :constraints nil
					    :name :includes
					    :fragment include))
       (bootstrap-classes module)))
    module))

(defvar *builtin-module* nil)

(define-clear-the-decks reset-builtin-module
  (setf *builtin-module* (make-builtin-module)))

;;;----- That's all, folks --------------------------------------------------