;;;
;;; classes.lisp
;;;
;;; Class definition machinery.
;;;

(cl:in-package :speakeasy)


;;;
;;; Classes.
;;;

;; As far as the VM is concerned, a class consists of a superclass, a
;; method dictionary and an instance specification (a SmallInteger).
;; This much is defined in class Behavior (three instance variables).

(defconstant +superclass-ofs+ 0)
(defconstant +method-dictionary-ofs+ 1)
(defconstant +instance-spec-ofs+ 2)

;; Layered over this is ClassDescription, which adds names for the
;; class and instance variables, comments, and grouping methods into
;; categories (call it four more instance variables; one for the class
;; name, one for the collection of instance variable names (an Array),
;; one for the class comment, and one for some structure for grouping
;; the methods).

(defconstant +instance-vars-ofs+ 5)

;; The next layer is Metaclass and Class.

;; As far as instance variabes go, Class has an additional one to hold
;; the class variable pool.

(defconstant +class-pool-ofs+ 7)

;; When a new class is created, the superclass is sent a message
;; indicating that a new subclass is wanted with a given name and
;; certain properties (instance variables, pools, etc.).  The
;; superclass turns around and sends a message to Metaclass asking for
;; a new metaclass to be created for the new subclass.  Metaclass then
;; creates the new metaclass for the new class and sends it a message
;; requesting that it create the new class.  I don't know if this is a
;; spiral dance, an innocent dance, or what, but it's certainly an
;; -intricate- dance.

;; For bootstrapping purposes, we accept two types of value for a
;; superclass.  The first is nil, used as Object's superclass.  The
;; second is a string, which is converted to a symbol OOP and looked
;; up in the system dictionary in order to find the corresponding
;; class OOP.

;; Interestingly, as every class's metaclass's class is supposed to be
;; Metaclass, including Metaclass itself, everything but Object's
;; metaclass being a subclass of Class is covered by the class
;; placeholder fixup mechanism.

(defun define-class (superclass name &key inst-vars class-vars (encoding :pointer))
  (let* ((superclass-oop (if superclass
			     (dictionary-at +smalltalk-oop+
					    (intern-symbol superclass))
			     +nil-oop+))
	 (supermeta-oop (if superclass
			    (ote-class (aref *object-table*
					     (ash superclass-oop -1)))
			    ;; If we have no superclass, this is
			    ;; supposed to be the OOP of Class, but
			    ;; since we are, by definition, defining
			    ;; Object we haven't defined Class yet, so
			    ;; we'll have to backpatch this later.
			    +nil-oop+))
	 (metaclass-oop (allocate-oop))
	 (class-oop (allocate-oop))
	 (superclass-instance-spec (if superclass
				       (obj-oop superclass-oop +instance-spec-ofs+)
				       #x8001))
	 (inherited-vars (ldb (byte 11 1) superclass-instance-spec)))

    (when (and (member encoding '(:variable-byte :variable-word))
	       (or (> inherited-vars 0)
		   inst-vars))
      (panic "non-pointer class definition has instance variables"))

    (make-object metaclass-oop :pointers 7 +metaclass-class-oop+)
    (setf (obj-oop metaclass-oop +superclass-ofs+) supermeta-oop)
    (setf (obj-oop metaclass-oop +method-dictionary-ofs+) (create-method-dictionary))
    (setf (obj-oop metaclass-oop +instance-spec-ofs+) (box-integer (logior #x4000 7)))

    (make-object class-oop :pointers 8 metaclass-oop)
    (setf (obj-oop class-oop +superclass-ofs+) superclass-oop)
    (setf (obj-oop class-oop +method-dictionary-ofs+) (create-method-dictionary))
    (setf (obj-oop class-oop +instance-spec-ofs+)
	  (box-integer (logior
			(ecase encoding
			  (:pointer #x4000)
			  (:variable #x5000)
			  (:variable-byte #x1000)
			  (:variable-word #x3000))
			(+
			 inherited-vars
			 (length inst-vars)))))

    (when inst-vars
      (let ((inst-vars-oop (allocate-oop)))
	(make-object inst-vars-oop :pointers (length inst-vars)
		     +array-class-oop+)
	(loop
	   for index from 0
	   for var in inst-vars
	   do (setf (obj-oop inst-vars-oop index)
		    (intern-string var)))
	(setf (obj-oop class-oop +instance-vars-ofs+) inst-vars-oop)))

    (when class-vars
      (let ((pool (create-dictionary)))
	(setf (obj-oop class-oop +class-pool-ofs+) pool)
	(dolist (var class-vars)
	  (dictionary-at-put pool (intern-symbol var) +nil-oop+))))

    (dictionary-at-put +smalltalk-oop+ (intern-symbol name) class-oop)))

;; Because we need to create objects well before we can create
;; classes, we use symbolic placeholders for some object classes.
;; Once the actual classes are defined we need to fixup the references
;; to the placeholder to point to the actual class instead.

(defun class-fixup (old-class new-class-name)
  "Fixup class references to OLD-CLASS in the object table to point to NEW-CLASS instead."
  (let ((new-class (dictionary-at +smalltalk-oop+
				  (intern-symbol new-class-name))))
    (loop for ob across *object-table*
	  when (and (ote-p ob)
		    (eql old-class (ote-class ob)))
	  do (setf (ote-class ob) new-class))
    new-class))

;; The compiler needs to know what instance variables are available
;; for a given class.

(defun class-instance-variables (class-oop)
  (let ((inst-vars (obj-oop class-oop +instance-vars-ofs+)))
    (unless (eql inst-vars +nil-oop+)
      (with-ote (ob inst-vars)
	(loop for name in (ote-data ob) collecting (extern-string name))))))

(defun all-class-instance-variables (class-oop)
  (let ((class-oops (list class-oop)))

    ;; Obtain a list of class oops in order from Object through CLASS.
    (loop
       for class = (car class-oops)
       for superclass = (obj-oop class +superclass-ofs+)
       until (eql superclass +nil-oop+)
       do (push superclass class-oops))

    ;; Collect the instance variables of each class in order.
    (loop
       for class in class-oops
       append (class-instance-variables class))))

;; The compiler also needs to know what variable pools are to be used
;; for compiling a given class.

(defun all-variable-pools-for-class (class-oop)
  (loop
     with class-pool
     for class = class-oop then (obj-oop class +superclass-ofs+)
     when (eql class +nil-oop+)
     collect +smalltalk-oop+
     and do (loop-finish)
     do (setf class-pool (obj-oop class +class-pool-ofs+))
     unless (eql class-pool +nil-oop+)
     collect class-pool))

;;; EOF
