[sod] / src / builtin.lisp

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

;;;--------------------------------------------------------------------------
;;; 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 called NAME (a string) 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, 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 :slot-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 "align" (class) size-t
  (format nil "SOD__ALIGNOF(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 class `~A' instance structure. */
static void *~:*~A__imprint(void *p)
{
  struct ~A *sod__obj = p;

  ~:{sod__obj->~A.~A._vt = &~A.~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)
			      (sod-class-nickname tail))))
		    (ilayout-ichains ilayout)))))

;;;--------------------------------------------------------------------------
;;; 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[] = {
~:{  { ~
    /*           n_classes = */ ~3@*~A,
    /*             classes = */ ~0@*~A__chain_~A,
    /*          off_ichain = */ ~4@*offsetof(struct ~A, ~A),
    /*                  vt = */ (const struct sod_vtable *)&~A,
    /*            ichainsz = */ 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 (car chain) head)))) ;7
		    chains))))

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

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

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

;;;--------------------------------------------------------------------------
;;; Built-in methods.

;; Common protocol.

(defclass lifecycle-message (standard-message)
  ())

(defclass lifecycle-effective-method (standard-effective-method)
  ())

(defmethod effective-method-live-p ((method lifecycle-effective-method))
  t)

(defgeneric lifecycle-method-kernel (method codegen target)
  (:documentation
   "Compute (into CODEGEN) the class-specific part of the METHOD.

   The result, if any, needs to find its way to the TARGET, as usual."))

(defmethod simple-method-body
    ((method lifecycle-effective-method) codegen target)
  (invoke-delegation-chain codegen target
			   (effective-method-basic-argument-names method)
			   (effective-method-primary-methods method)
			   (lambda (target)
			     (lifecycle-method-kernel method
						      codegen
						      target))))

;; Utilities.

(defun declare-me (codegen class)
  "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS.

   The pointer refers to a part of the prevailing `sod__obj' object, which is
   assumed to be a pointer to an appropriate `ilayout' structure."
  (emit-decl codegen (make-var-inst "me" (c-type (* (class class)))
				    (format nil "&sod__obj->~A.~A"
					    (sod-class-nickname
					     (sod-class-chain-head class))
					    (sod-class-nickname class)))))

(defun collect-initarg-keywords (class)
  "Return a list of keyword arguments corresponding to CLASS's initargs.

   For each distinct name among the initargs defined on CLASS and its
   superclasses, return a single `argument' object containing the (agreed
   common) type, and the (unique, if present) default value from the most
   specific defining superclass.

   The arguments are not returned in any especially meaningful order."

  (let ((map (make-hash-table :test #'equal))
	(default-map (make-hash-table :test #'equal))
	(list nil))
    (dolist (super (sod-class-precedence-list class))
      (dolist (initarg (sod-class-initargs super))
	(let ((name (sod-initarg-name initarg))
	      (default (sod-initarg-default initarg)))
	  (unless (gethash name default-map)
	    (when (or default (not (gethash name map)))
	      (setf (gethash name map) (sod-initarg-argument initarg)))
	    (when default
	      (setf (gethash name default-map) t))))))
    (maphash (lambda (key value)
	       (declare (ignore key))
	       (push value list))
	     map)
    list))

(definst suppliedp-struct (stream) (flags var)
  (format stream
	  "~@<struct { ~2I~_~{unsigned ~A: 1;~^ ~_~} ~I~_} ~A;~:>"
	  flags var))

;; Initialization.

(defclass initialization-message (lifecycle-message)
  ())

(defclass initialization-effective-method (lifecycle-effective-method)
  ())

(defmethod sod-message-effective-method-class
    ((message initialization-message))
  'initialization-effective-method)

(defmethod sod-message-keyword-argument-lists
    ((message initialization-message) (class sod-class) direct-methods state)
  (append (call-next-method)
	  (mapcan (lambda (class)
		    (let* ((initargs (sod-class-initargs class))
			   (map (make-hash-table))
			   (arglist (mapcar
				     (lambda (initarg)
				       (let ((arg (sod-initarg-argument
						   initarg)))
					 (setf (gethash arg map) initarg)
					 arg))
				     initargs)))
		      (and initargs
			   (list (cons (lambda (arg)
					 (info-with-location
					  (gethash arg map)
					  "Type `~A' from initarg ~
					   in class `~A' (here)"
					  (argument-type arg) class)
					 (report-inheritance-path
					  state class))
				       arglist)))))
		  (sod-class-precedence-list class))))

(defmethod lifecycle-method-kernel
    ((method initialization-effective-method) codegen target)
  (let* ((class (effective-method-class method))
	 (keywords (collect-initarg-keywords class))
	 (ilayout (sod-class-ilayout class))
	 (obj-tag (ilayout-struct-tag class))
	 (kw-tag (effective-method-keyword-struct-tag method))
	 (kw-tail (and keywords
		       (list (make-argument
			      "sod__kw"
			      (c-type (* (struct kw-tag :const)))))))
	 (func-type (c-type (fun void
				 ("sod__obj" (* (struct obj-tag)))
				 . kw-tail)))
	 (func-name (format nil "~A__init" class))
	 (done-setup-p nil))

    ;; Start building the initialization function.
    (codegen-push codegen)

    (labels ((set-from-initializer (var type init)
	       ;; Store the value of INIT, which has the given TYPE, in VAR.
	       ;; INIT has the syntax of an initializer: declare and
	       ;; initialize a temporary, and then copy the result.
	       ;; Compilers seem to optimize this properly.  Return the
	       ;; resulting code as an instruction.
	       (codegen-push codegen)
	       (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
	       (deliver-expr codegen var *sod-tmp-val*)
	       (codegen-pop-block codegen))
	     (setup ()
	       ;; Do any necessary one-time initialization required to set up
	       ;; the environment for the initialization code.
	       (unless done-setup-p

		 ;; Extract the keyword arguments into local variables.
		 (when keywords
		   (emit-decl codegen
			      (make-suppliedp-struct-inst
			       (mapcar #'argument-name keywords)
			       "suppliedp"))
		   (emit-banner codegen "Collect the keyword arguments.")
		   (dolist (arg keywords)
		     (let* ((name (argument-name arg))
			    (type (argument-type arg))
			    (default (argument-default arg))
			    (kwvar (format nil "sod__kw->~A" name))
			    (kwset (make-set-inst name kwvar))
			    (suppliedp (format nil "suppliedp.~A" name)))
		       (emit-decl codegen (make-var-inst name type))
		       (deliver-expr codegen suppliedp
				     (format nil "sod__kw->~A__suppliedp"
					     name))
		       (emit-inst
			codegen
			(if default
			    (make-if-inst suppliedp kwset
					  (set-from-initializer name
								type
								default))
			    kwset))))

		   (deliver-call codegen :void
				 "SOD__IGNORE" "suppliedp")
		   (dolist (arg keywords)
		     (deliver-call codegen :void
				   "SOD__IGNORE" (argument-name arg))))

		 (setf done-setup-p t))))

      ;; Initialize the structure defined by the various superclasses, in
      ;; reverse precedence order.
      (dolist (super (reverse (sod-class-precedence-list class)))
	(let* ((ichain (find (sod-class-chain-head super)
			     (ilayout-ichains ilayout)
			     :key #'ichain-head))
	       (islots (find super (ichain-body ichain)
			     :test (lambda (class item)
				     (and (typep item 'islots)
					  (eq (islots-class item) class)))))
	       (frags (sod-class-initfrags super))
	       (this-class-focussed-p nil)
	       (isl (format nil "me->~A" (sod-class-nickname super))))

	  (flet ((focus-this-class ()
		   ;; Delayed initial preparation.  Don't bother defining the
		   ;; `me' pointer if there's actually nothing to do.
		   (setup)
		   (unless this-class-focussed-p
		     (emit-banner codegen
				  "Initialization for class `~A'." super)
		     (codegen-push codegen)
		     (declare-me codegen super)
		     (setf this-class-focussed-p t))))

	    ;; Work through each slot in turn.
	    (dolist (slot (and islots (islots-slots islots)))
	      (let ((dslot (effective-slot-direct-slot slot))
		    (init (effective-slot-initializer slot))
		    (initargs (effective-slot-initargs slot)))
		(when (or init initargs)
		  (focus-this-class)
		  (let* ((slot-type (sod-slot-type dslot))
			 (slot-default (sod-initializer-value init))
			 (target (format nil "~A.~A"
					 isl (sod-slot-name dslot)))
			 (initinst (set-from-initializer target
							 slot-type
							 slot-default)))

		    ;; If there are applicable initialization arguments,
		    ;; check to see whether they were supplied.
		    (dolist (initarg (reverse (remove-duplicates
					       initargs
					       :key #'sod-initarg-name
					       :test #'string=)))
		      (let ((arg-name (sod-initarg-name initarg)))
			(setf initinst (make-if-inst
					(format nil "suppliedp.~A" arg-name)
					(make-set-inst target arg-name)
					initinst))))

		    (emit-inst codegen initinst)))))

	    ;; Emit the class's initialization fragments.
	    (when frags
	      (let ((used-me-p this-class-focussed-p))
		(focus-this-class)
		(unless used-me-p
		  (deliver-call codegen :void "SOD__IGNORE" "me")))
	      (dolist (frag frags)
		(codegen-push codegen)
		(emit-inst codegen frag)
		(emit-inst codegen (codegen-pop-block codegen))))

	    ;; If we opened a block to initialize this class then close it
	    ;; again.
	    (when this-class-focussed-p
	      (emit-inst codegen (codegen-pop-block codegen)))))))

    ;; Done making the initialization function.
    (codegen-pop-function codegen func-name func-type
			  "Instance initialization function ~:_~
			   for class `~A'."
			  class)

    (apply #'deliver-call codegen :void func-name
	   "sod__obj" (and keywords (list (keyword-struct-pointer))))))

;; Teardown.

(defclass teardown-message (lifecycle-message)
  ())

(defclass teardown-effective-method (lifecycle-effective-method)
  ())

(defmethod sod-message-effective-method-class ((message teardown-message))
  'teardown-effective-method)

(defmethod lifecycle-method-kernel
    ((method teardown-effective-method) codegen target)
  (let* ((class (effective-method-class method))
	 (obj-tag (ilayout-struct-tag class))
	 (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
	 (func-name (format nil "~A__teardown" class)))
    (codegen-push codegen)
    (dolist (super (sod-class-precedence-list class))
      (let ((frags (sod-class-tearfrags super)))
	(when frags
	  (emit-banner codegen "Teardown for class `~A'." super)
	  (codegen-push codegen)
	  (declare-me codegen super)
	  (deliver-call codegen :void "SOD__IGNORE" "me")
	  (dolist (frag frags)
	    (codegen-push codegen)
	    (emit-inst codegen frag)
	    (emit-inst codegen (codegen-pop-block codegen)))
	  (emit-inst codegen (codegen-pop-block codegen)))))
    (codegen-pop-function codegen func-name func-type
			  "Instance teardown function ~:_~
			   for class `~A'."
			  class)
    (deliver-call codegen :void
		  (format nil "~A__teardown" class) "sod__obj")
    (deliver-expr codegen target 0)))

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

(defun bootstrap-classes (module)
  "Bootstrap the braid in MODULE.

   This builds the fundamental recursive braid, where `SodObject' is an
   instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
   an instance of itself)."
  (let* ((sod-object (make-sod-class "SodObject" nil
				     (make-property-set :nick 'obj
							:%bootstrapping t)))
	 (sod-class (make-sod-class "SodClass" (list sod-object)
				    (make-property-set :nick 'cls
						       :%bootstrapping t)))
	 (classes (list sod-object sod-class)))

    ;; Attach the built-in messages.
    (make-sod-message sod-object "init"
		      (c-type (fun void :keys))
		      (make-property-set
		       :message-class 'initialization-message))
    (make-sod-message sod-object "teardown" (c-type (fun int))
		      (make-property-set :message-class 'teardown-message))

    ;; 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)
      (unless (finalize-sod-class class)
	(error "Failed to finalize built-in class"))
      (add-to-module module class))))

(export '*builtin-module*)
(defvar-unbound *builtin-module*
  "The builtin module.")

(export 'make-builtin-module)
(defun make-builtin-module ()
  "Construct the builtin module.

   This involves constructing the braid (which is done in
   `bootstrap-classes') and defining a few obvious type names which users
   will find handy.

   Returns the newly constructed module, and stores it in the variable
   `*builtin-module*'."
  (let ((module (make-instance 'module
			       :name (make-pathname :name "SOD-BASE"
						    :type "SOD"
						    :case :common)
			       :state nil)))
    (with-module-environment (module)
      (flet ((header-name (name)
	       (concatenate 'string "\"" (string-downcase name) ".h\""))
	     (add-includes (reason &rest names)
	       (let ((text (with-output-to-string (out)
			     (dolist (name names)
			       (format out "#include ~A~%" name)))))
		 (add-to-module module
				(make-instance 'code-fragment-item
					       :reason reason
					       :constraints nil
					       :name :includes
					       :fragment text)))))
	(add-includes :c (header-name "sod"))
	(add-includes :h "<stddef.h>"))
      (bootstrap-classes module))
    (setf *builtin-module* module)))

(define-clear-the-decks builtin-module
  (unless (boundp '*builtin-module*) (make-builtin-module)))

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