chiark - git - mdw - sod/blob - pre-reorg/cpl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Computing class precedence lists
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Linearizations.
  30
  31 ;;;--------------------------------------------------------------------------
  32 ;;; Class protocol.
  33
  34 (defgeneric compute-cpl (class)
  35   (:documentation
  36    "Returns the class precedence list for CLASS."))
  37
  38 ;;;--------------------------------------------------------------------------
  39 ;;; Testing.
  40
  41 #+test
  42 (progn
  43   (defclass test-class ()
  44     ((name :initarg :name :accessor sod-class-name)
  45      (direct-superclasses :initarg :superclasses
  46                           :accessor sod-class-direct-superclasses)
  47      (class-precedence-list)))
  48
  49   (defmethod print-object ((class test-class) stream)
  50     (if *print-escape*
  51         (print-unreadable-object (class stream :type t :identity nil)
  52           (princ (sod-class-name class) stream))
  53         (princ (sod-class-name class) stream)))
  54
  55   (defvar *test-linearization*)
  56
  57   (defmethod sod-class-precedence-list ((class test-class))
  58     (if (slot-boundp class 'class-precedence-list)
  59         (slot-value class 'class-precedence-list)
  60         (setf (slot-value class 'class-precedence-list)
  61               (funcall *test-linearization* class)))))
  62
  63 #+test
  64 (defun test-cpl (linearization heterarchy)
  65   (let* ((*test-linearization* linearization)
  66          (classes (make-hash-table :test #'equal)))
  67     (dolist (class heterarchy)
  68       (let ((name (car class)))
  69         (setf (gethash (car class) classes)
  70               (make-instance 'test-class :name name))))
  71     (dolist (class heterarchy)
  72       (setf (sod-class-direct-superclasses (gethash (car class) classes))
  73             (mapcar (lambda (super) (gethash super classes)) (cdr class))))
  74     (mapcar (lambda (class)
  75               (handler-case
  76                   (mapcar #'sod-class-name
  77                           (sod-class-precedence-list (gethash (car class)
  78                                                               classes)))
  79                 (inconsistent-merge-error ()
  80                   (list (car class) :error))))
  81             heterarchy)))
  82
  83 #+test
  84 (progn
  85   (defparameter *confused-heterarchy*
  86     '((object) (grid-layout object)
  87       (horizontal-grid grid-layout) (vertical-grid grid-layout)
  88       (hv-grid horizontal-grid vertical-grid)
  89       (vh-grid vertical-grid horizontal-grid)
  90       (confused-grid hv-grid vh-grid)))
  91   (defparameter *boat-heterarchy*
  92     '((object)
  93       (boat object)
  94       (day-boat boat)
  95       (wheel-boat boat)
  96       (engine-less day-boat)
  97       (small-multihull day-boat)
  98       (pedal-wheel-boat engine-less wheel-boat)
  99       (small-catamaran small-multihull)
 100       (pedalo pedal-wheel-boat small-catamaran)))
 101   (defparameter *menu-heterarchy*
 102     '((object)
 103       (choice-widget object)
 104       (menu choice-widget)
 105       (popup-mixin object)
 106       (popup-menu menu popup-mixin)
 107       (new-popup-menu menu popup-mixin choice-widget)))
 108   (defparameter *pane-heterarchy*
 109     '((pane) (scrolling-mixin) (editing-mixin)
 110       (scrollable-pane pane scrolling-mixin)
 111       (editable-pane pane editing-mixin)
 112       (editable-scrollable-pane scrollable-pane editable-pane)))
 113   (defparameter *baker-nonmonotonic-heterarchy*
 114     '((z) (x z) (y) (b y) (a b x) (c a b x y)))
 115   (defparameter *baker-nonassociative-heterarchy*
 116     '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
 117   (defparameter *distinguishing-heterarchy*
 118     '((object)
 119       (a object) (b object) (c object)
 120       (p a b) (q a c)
 121       (u p) (v q)
 122       (x u v)
 123       (y x b c)
 124       (z x c b)))
 125   (defparameter *python-heterarchy*
 126     '((object)
 127       (a object) (b object) (c object) (d object) (e object)
 128       (k1 a b c)
 129       (k2 d b e)
 130       (k3 d a)
 131       (z k1 k2 k3))))
 132
 133 ;;;----- That's all, folks --------------------------------------------------