X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/bf090e021a5c20da452a4841cdfb8eb78e29544e..aa14a4cddcb96b681d5c19a2ec8bad382f43b264:/src/impl-class-layout.lisp

diff --git a/src/impl-class-layout.lisp b/src/impl-class-layout.lisp
deleted file mode 100644
index 4bff54d..0000000
--- a/src/impl-class-layout.lisp
+++ /dev/null
@@ -1,395 +0,0 @@
-;;; -*-lisp-*-
-;;;
-;;; Class layout protocol implementation
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Effective slots.
-
-(defmethod print-object ((slot effective-slot) stream)
-  (maybe-print-unreadable-object (slot stream :type t)
-    (format stream "~A~@[ = ~@_~A~]"
-	    (effective-slot-direct-slot slot)
-	    (effective-slot-initializer slot))))
-
-(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
-  (some (lambda (super)
-	  (find slot
-		(sod-class-instance-initializers super)
-		:key #'sod-initializer-slot))
-	(sod-class-precedence-list class)))
-
-(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
-  (make-instance 'effective-slot
-		 :slot slot
-		 :class class
-		 :initializer (find-slot-initializer class slot)))
-
-;;;--------------------------------------------------------------------------
-;;; Special-purpose slot objects.
-
-(export 'sod-class-slot)
-(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."))
-
-(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)))
-
-(export 'sod-class-effective-slot)
-(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)))
-
-;;;--------------------------------------------------------------------------
-;;; Effective methods.
-
-(defmethod print-object ((method effective-method) stream)
-  (maybe-print-unreadable-object (method stream :type t)
-    (format stream "~A ~A"
-	    (effective-method-message method)
-	    (effective-method-class method))))
-
-(defmethod print-object ((entry method-entry) stream)
-  (maybe-print-unreadable-object (entry stream :type t)
-    (format stream "~A:~A"
-	    (method-entry-effective-method entry)
-	    (sod-class-nickname (method-entry-chain-head entry)))))
-
-(defmethod compute-sod-effective-method
-    ((message sod-message) (class sod-class))
-  (let ((direct-methods (mappend (lambda (super)
-				   (remove message
-					   (sod-class-methods super)
-					   :key #'sod-method-message
-					   :test-not #'eql))
-				(sod-class-precedence-list class))))
-    (make-instance (message-effective-method-class message)
-		   :message message
-		   :class class
-		   :direct-methods direct-methods)))
-
-(defmethod compute-effective-methods ((class sod-class))
-  (mapcan (lambda (super)
-	    (mapcar (lambda (message)
-		      (compute-sod-effective-method message class))
-		    (sod-class-messages super)))
-	  (sod-class-precedence-list class)))
-
-(defmethod slot-unbound
-    (clos-class (class sod-class) (slot-name (eql 'effective-methods)))
-  (setf (slot-value class 'effective-methods)
-	(compute-effective-methods class)))
-
-;;;--------------------------------------------------------------------------
-;;; Instance layout.
-
-;;; islots
-
-(defmethod print-object ((islots islots) stream)
-  (print-unreadable-object (islots stream :type t)
-    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (islots-subclass islots)
-	    (islots-class islots)
-	    (islots-slots islots))))
-
-(defmethod compute-islots ((class sod-class) (subclass sod-class))
-  (make-instance 'islots
-		 :class class
-		 :subclass subclass
-		 :slots (mapcar (lambda (slot)
-				  (compute-effective-slot subclass slot))
-				(sod-class-slots class))))
-
-;;; vtable-pointer
-;;; Do we need a construction protocol here?
-
-(defmethod print-object ((vtp vtable-pointer) stream)
-  (print-unreadable-object (vtp stream :type t)
-    (format stream "~A:~A"
-	    (vtable-pointer-class vtp)
-	    (sod-class-nickname (vtable-pointer-chain-head vtp)))))
-
-;;; ichain
-
-(defmethod print-object ((ichain ichain) stream)
-  (print-unreadable-object (ichain stream :type t)
-    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (ichain-class ichain)
-	    (sod-class-nickname (ichain-head ichain))
-	    (ichain-body ichain))))
-
-(defmethod compute-ichain ((class sod-class) chain)
-  (let* ((chain-head (car chain))
-	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
-			   :key #'sod-class-chain-head))
-	 (vtable-pointer (make-instance 'vtable-pointer
-					:class class
-					:chain-head chain-head
-					:chain-tail chain-tail))
-	 (islots (remove-if-not #'islots-slots
-				(mapcar (lambda (super)
-					  (compute-islots super class))
-					chain))))
-    (make-instance 'ichain
-		   :class class
-		   :chain-head chain-head
-		   :chain-tail chain-tail
-		   :body (cons vtable-pointer islots))))
-
-;;; ilayout
-
-(defmethod print-object ((ilayout ilayout) stream)
-  (print-unreadable-object (ilayout stream :type t)
-    (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (ilayout-class ilayout)
-	    (ilayout-ichains ilayout))))
-
-(defmethod compute-ilayout ((class sod-class))
-  (make-instance 'ilayout
-		 :class class
-		 :ichains (mapcar (lambda (chain)
-				    (compute-ichain class
-						    (reverse chain)))
-				  (sod-class-chains class))))
-
-(defmethod slot-unbound
-    (clos-class (class sod-class) (slot-name (eql 'ilayout)))
-  (setf (slot-value class 'ilayout)
-	(compute-ilayout class)))
-
-;;;--------------------------------------------------------------------------
-;;; Vtable layout.
-
-;;; vtmsgs
-
-(defmethod print-object ((vtmsgs vtmsgs) stream)
-  (print-unreadable-object (vtmsgs stream :type t)
-    (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (vtmsgs-subclass vtmsgs)
-	    (vtmsgs-class vtmsgs)
-	    (vtmsgs-entries vtmsgs))))
-
-(defmethod compute-vtmsgs
-    ((class sod-class)
-     (subclass sod-class)
-     (chain-head sod-class)
-     (chain-tail sod-class))
-  (flet ((make-entry (message)
-	   (let ((method (find message
-			       (sod-class-effective-methods subclass)
-			       :key #'effective-method-message)))
-	     (make-method-entry method chain-head chain-tail))))
-    (make-instance 'vtmsgs
-		   :class class
-		   :subclass subclass
-		   :chain-head chain-head
-		   :chain-tail chain-tail
-		   :entries (mapcar #'make-entry
-				    (sod-class-messages class)))))
-
-;;; class-pointer
-
-(defmethod print-object ((cptr class-pointer) stream)
-  (print-unreadable-object (cptr stream :type t)
-    (format stream "~A:~A"
-	    (class-pointer-metaclass cptr)
-	    (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
-
-(defmethod make-class-pointer
-    ((class sod-class) (chain-head sod-class)
-     (metaclass sod-class) (meta-chain-head sod-class))
-
-  ;; Slightly tricky.  We don't necessarily want a pointer to the metaclass,
-  ;; but to its most specific subclass on the given chain.  Fortunately, CL
-  ;; is good at this game.
-  (let* ((meta-chains (sod-class-chains metaclass))
-	 (meta-chain-tails (mapcar #'car meta-chains))
-	 (meta-chain-tail (find meta-chain-head meta-chain-tails
-				:key #'sod-class-chain-head)))
-    (make-instance 'class-pointer
-		   :class class
-		   :chain-head chain-head
-		   :metaclass meta-chain-tail
-		   :meta-chain-head meta-chain-head)))
-
-;;; base-offset
-
-(defmethod print-object ((boff base-offset) stream)
-  (print-unreadable-object (boff stream :type t)
-    (format stream "~A:~A"
-	    (base-offset-class boff)
-	    (sod-class-nickname (base-offset-chain-head boff)))))
-
-(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
-  (make-instance 'base-offset
-		 :class class
-		 :chain-head chain-head))
-
-;;; chain-offset
-
-(defmethod print-object ((choff chain-offset) stream)
-  (print-unreadable-object (choff stream :type t)
-    (format stream "~A:~A->~A"
-	    (chain-offset-class choff)
-	    (sod-class-nickname (chain-offset-chain-head choff))
-	    (sod-class-nickname (chain-offset-target-head choff)))))
-
-(defmethod make-chain-offset
-    ((class sod-class) (chain-head sod-class) (target-head sod-class))
-  (make-instance 'chain-offset
-		 :class class
-		 :chain-head chain-head
-		 :target-head target-head))
-
-;;; vtable
-
-(defmethod print-object ((vtable vtable) stream)
-  (print-unreadable-object (vtable stream :type t)
-    (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
-	    (vtable-class vtable)
-	    (sod-class-nickname (vtable-chain-head vtable))
-	    (vtable-body vtable))))
-
-;; Special variables used by `compute-vtable'.
-(defvar *done-metaclass-chains*)
-(defvar *done-instance-chains*)
-
-(defmethod compute-vtable-items
-    ((class sod-class) (super sod-class) (chain-head sod-class)
-     (chain-tail sod-class) (emit function))
-
-  ;; If this class introduces new metaclass chains, then emit pointers to
-  ;; them.
-  (let* ((metasuper (sod-class-metaclass super))
-	 (metasuper-chains (sod-class-chains metasuper))
-	 (metasuper-chain-heads (mapcar (lambda (chain)
-					  (sod-class-chain-head (car chain)))
-					metasuper-chains)))
-    (dolist (metasuper-chain-head metasuper-chain-heads)
-      (unless (member metasuper-chain-head *done-metaclass-chains*)
-	(funcall emit (make-class-pointer class
-					  chain-head
-					  metasuper
-					  metasuper-chain-head))
-	(push metasuper-chain-head *done-metaclass-chains*))))
-
-  ;; If there are new instance chains, then emit offsets to them.
-  (let* ((chains (sod-class-chains super))
-	 (chain-heads (mapcar (lambda (chain)
-				(sod-class-chain-head (car chain)))
-			      chains)))
-    (dolist (head chain-heads)
-      (unless (member head *done-instance-chains*)
-	(funcall emit (make-chain-offset class chain-head head))
-	(push head *done-instance-chains*))))
-
-  ;; Finally, if there are interesting methods, emit those too.
-  (when (sod-class-messages super)
-    (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
-
-(defmethod compute-vtable ((class sod-class) (chain list))
-  (let* ((chain-head (car chain))
-	 (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
-			   :key #'sod-class-chain-head))
-	 (*done-metaclass-chains* nil)
-	 (*done-instance-chains* (list chain-head))
-	 (done-superclasses nil)
-	 (items nil))
-    (flet ((emit (item)
-	     (push item items)))
-
-      ;; Find the root chain in the metaclass and write a pointer.
-      (let* ((metaclass (sod-class-metaclass class))
-	     (metaclass-root (find-root-metaclass class))
-	     (metaclass-root-head (sod-class-chain-head metaclass-root)))
-	(emit (make-class-pointer class chain-head metaclass
-				  metaclass-root-head))
-	(push metaclass-root-head *done-metaclass-chains*))
-
-      ;; Write an offset to the instance base.
-      (emit (make-base-offset class chain-head))
-
-      ;; Now walk the chain.  As we ascend the chain, scan the class
-      ;; precedence list of each class in reverse to ensure that we have
-      ;; everything interesting.
-      (dolist (super chain)
-	(dolist (sub (reverse (sod-class-precedence-list super)))
-	  (unless (member sub done-superclasses)
-	    (compute-vtable-items class
-				  sub
-				  chain-head
-				  chain-tail
-				  #'emit)
-	    (push sub done-superclasses))))
-
-      ;; We're through.
-      (make-instance 'vtable
-		     :class class
-		     :chain-head chain-head
-		     :chain-tail chain-tail
-		     :body (nreverse items)))))
-
-(defmethod compute-vtables ((class sod-class))
-  (mapcar (lambda (chain)
-	    (compute-vtable class (reverse chain)))
-	  (sod-class-chains class)))
-
-(defmethod slot-unbound
-    (clos-class (class sod-class) (slot-name (eql 'vtables)))
-  (setf (slot-value class 'vtables)
-	(compute-vtables class)))
-
-;;;----- That's all, folks --------------------------------------------------