It lives!

[sod] / builtin.lisp

;;; -*-lisp-*-
;;;
;;; Builtin module provides basic definitions
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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)

;;;--------------------------------------------------------------------------
;;; Output of class instances.

(defun output-imprint-function (class stream)
  (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)))))

(defun output-init-function (class stream)
  ;; 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 =" isl)
		     (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%")))

(defun output-supers-vector (class stream)
  (let ((supers (sod-class-direct-superclasses class)))
    (when supers
      (format stream "~&~:
/* Direct superclasses. */
static const SodClass *const ~A__supers[] = {
  ~{~A__class~^,~%  ~}
};~2%"
	      class supers))))

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

(defun output-chains-vector (class stream)
  (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))))

(defclass sod-class-slot (sod-slot)
  ((initializer-function :initarg :initializer-function
			 :type (or symbol function)
			 :reader sod-slot-initializer-function)
   (prepare-function :initarg :prepare-function :type (or symbol function)
		     :reader sod-slot-prepare-function))
  (:documentation
   "Special class for slots defined on SodClass.

   These slots need class-specific initialization.  It's easier to keep all
   of the information (name, type, and how to initialize them) about these
   slots in one place, so that's what we do here."))

(defclass sod-magic-class-initializer (sod-class-initializer)
  ((initializer-function :initarg :initializer-function
			 :type (or symbol function)
			 :reader sod-initializer-function)
   (prepare-function  :initarg :prepare-function
		      :type (or symbol function)
		      :reader sod-initializer-prepare-function)))

(defmethod shared-initialize :after
    ((slot sod-class-slot) slot-names &key pset)
  (declare (ignore slot-names))
  (default-slot (slot 'initializer-function)
    (get-property pset :initializer-function t nil))
  (default-slot (slot 'prepare-function)
    (get-property pset :prepare-function t nil)))

(defclass sod-class-effective-slot (effective-slot)
  ((initializer-function :initarg :initializer-function
			 :type (or symbol function)
			 :reader effective-slot-initializer-function)
   (prepare-function :initarg :prepare-function :type (or symbol function)
		     :reader effective-slot-prepare-function))
  (:documentation
   "Special class for slots defined on SodClass.

   This class ignores any explicit initializers and computes initializer
   values using the slot's INIT-FUNC slot and a magical protocol during
   metaclass instance construction."))

(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
  (make-instance 'sod-class-effective-slot
		 :class class :slot slot
		 :initializer-function (sod-slot-initializer-function slot)
		 :prepare-function (sod-slot-prepare-function slot)
		 :initializer (find-slot-initializer class slot)))

;;;--------------------------------------------------------------------------
;;; Class slots table.

(defparameter *sod-class-slots*
  `(

    ;; Basic informtion.
    ("name" ,(c-type const-string)
	    :initializer-function
	    ,(lambda (class)
	       (prin1-to-string (sod-class-name class))))
    ("nick" ,(c-type const-string)
	    :initializer-function
	    ,(lambda (class)
	       (prin1-to-string (sod-class-nickname class))))

    ;; Instance allocation and initialization.
    ("instsz" ,(c-type size-t)
	      :initializer-function
	      ,(lambda (class)
		 (format nil "sizeof(struct ~A)"
			 (ilayout-struct-tag class))))
    ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
	       :prepare-function output-imprint-function
	       :initializer-function
	       ,(lambda (class)
		  (format nil "~A__imprint" class)))
    ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
	    :prepare-function output-init-function
	    :initializer-function
	    ,(lambda (class)
	       (format nil "~A__init" class)))

    ;; Superclass structure.
    ("n_supers" ,(c-type size-t)
		:initializer-function
		,(lambda (class)
		   (length (sod-class-direct-superclasses class))))
    ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
	      :prepare-function output-supers-vector
	      :initializer-function
	      ,(lambda (class)
		 (if (sod-class-direct-superclasses class)
		     (format nil "~A__supers" class)
		     0)))
    ("n_cpl" ,(c-type size-t)
	     :initializer-function
		,(lambda (class)
		   (length (sod-class-precedence-list class))))
    ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
	   :prepare-function output-cpl-vector
	   :initializer-function
	   ,(lambda (class)
	      (format nil "~A__cpl" class)))

    ;; Chain structure.
    ("link" ,(c-type (* (class "SodClass" :const)))
	    :initializer-function
	    ,(lambda (class)
	       (let ((link (sod-class-chain-link class)))
		 (if link
		     (format nil "~A__class" link)
		     0))))
    ("head" ,(c-type (* (class "SodClass" :const)))
	    :initializer-function
	    ,(lambda (class)
	       (format nil "~A__class" (sod-class-chain-head class))))
    ("level" ,(c-type size-t)
	     :initializer-function
	     ,(lambda (class)
		(position class (reverse (sod-class-chain class)))))
    ("n_chains" ,(c-type size-t)
		:initializer-function
		,(lambda (class)
		   (length (sod-class-chains class))))
    ("chains" ,(c-type (* (struct "sod_chain" :const)))
	      :prepare-function output-chains-vector
	      :initializer-function
	      ,(lambda (class)
		 (format nil "~A__chains" class)))

    ;; Class-specific layout.
    ("off_islots" ,(c-type size-t)
		  :initializer-function
		  ,(lambda (class)
		     (format nil "offsetof(struct ~A, ~A)"
			     (ichain-struct-tag class
						(sod-class-chain-head class))
			     (sod-class-nickname class))))
    ("islotsz" ,(c-type size-t)
	       :initializer-function
	       ,(lambda (class)
		  (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.
    (loop for (name type . plist) in *sod-class-slots*
	  do (make-sod-slot sod-class name type
			    (apply #'make-property-set
				   :lisp-class 'sod-class-slot
				   plist)))

    ;; 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))
	(*type-map* (make-hash-table :test #'equal)))
    (dolist (name '("va_list" "size_t" "ptrdiff_t"))
      (add-to-module module (make-instance 'type-item :name name)))
    (bootstrap-classes module)
    module))

(defun reset-builtin-module ()
  (setf *builtin-module* (make-builtin-module))
  (module-import *builtin-module*))

;;;--------------------------------------------------------------------------
;;; Testing.

#+test
(define-sod-class "AbstractStack" ("SodObject")
  :nick 'abstk
  (message "emptyp" (fun int))
  (message "push" (fun void ("item" (* void))))
  (message "pop" (fun (* void)))
  (method "abstk" "pop" (fun void) #{
     assert(!me->_vt.emptyp());
   }
   :role :before))

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