src/class-output.lisp: Output effective methods directly from the class.

[sod] / pre-reorg / cpl.lisp

;;; -*-lisp-*-
;;;
;;; Computing class precedence lists
;;;
;;; (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)

;;;--------------------------------------------------------------------------
;;; Linearizations.

;;;--------------------------------------------------------------------------
;;; Class protocol.

(defgeneric compute-cpl (class)
  (:documentation
   "Returns the class precedence list for CLASS."))

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

#+test
(progn
  (defclass test-class ()
    ((name :initarg :name :accessor sod-class-name)
     (direct-superclasses :initarg :superclasses
			  :accessor sod-class-direct-superclasses)
     (class-precedence-list)))

  (defmethod print-object ((class test-class) stream)
    (if *print-escape*
	(print-unreadable-object (class stream :type t :identity nil)
	  (princ (sod-class-name class) stream))
	(princ (sod-class-name class) stream)))

  (defvar *test-linearization*)

  (defmethod sod-class-precedence-list ((class test-class))
    (if (slot-boundp class 'class-precedence-list)
	(slot-value class 'class-precedence-list)
	(setf (slot-value class 'class-precedence-list)
	      (funcall *test-linearization* class)))))

#+test
(defun test-cpl (linearization heterarchy)
  (let* ((*test-linearization* linearization)
	 (classes (make-hash-table :test #'equal)))
    (dolist (class heterarchy)
      (let ((name (car class)))
	(setf (gethash (car class) classes)
	      (make-instance 'test-class :name name))))
    (dolist (class heterarchy)
      (setf (sod-class-direct-superclasses (gethash (car class) classes))
	    (mapcar (lambda (super) (gethash super classes)) (cdr class))))
    (mapcar (lambda (class)
	      (handler-case
		  (mapcar #'sod-class-name
			  (sod-class-precedence-list (gethash (car class)
							      classes)))
		(inconsistent-merge-error ()
		  (list (car class) :error))))
	    heterarchy)))

#+test
(progn
  (defparameter *confused-heterarchy*
    '((object) (grid-layout object)
      (horizontal-grid grid-layout) (vertical-grid grid-layout)
      (hv-grid horizontal-grid vertical-grid)
      (vh-grid vertical-grid horizontal-grid)
      (confused-grid hv-grid vh-grid)))
  (defparameter *boat-heterarchy*
    '((object)
      (boat object)
      (day-boat boat)
      (wheel-boat boat)
      (engine-less day-boat)
      (small-multihull day-boat)
      (pedal-wheel-boat engine-less wheel-boat)
      (small-catamaran small-multihull)
      (pedalo pedal-wheel-boat small-catamaran)))
  (defparameter *menu-heterarchy*
    '((object)
      (choice-widget object)
      (menu choice-widget)
      (popup-mixin object)
      (popup-menu menu popup-mixin)
      (new-popup-menu menu popup-mixin choice-widget)))
  (defparameter *pane-heterarchy*
    '((pane) (scrolling-mixin) (editing-mixin)
      (scrollable-pane pane scrolling-mixin)
      (editable-pane pane editing-mixin)
      (editable-scrollable-pane scrollable-pane editable-pane)))
  (defparameter *baker-nonmonotonic-heterarchy*
    '((z) (x z) (y) (b y) (a b x) (c a b x y)))
  (defparameter *baker-nonassociative-heterarchy*
    '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
  (defparameter *distinguishing-heterarchy*
    '((object)
      (a object) (b object) (c object)
      (p a b) (q a c)
      (u p) (v q)
      (x u v)
      (y x b c)
      (z x c b)))
  (defparameter *python-heterarchy*
    '((object)
      (a object) (b object) (c object) (d object) (e object)
      (k1 a b c)
      (k2 d b e)
      (k3 d a)
      (z k1 k2 k3))))

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