src/{class-,}utilities.lisp: Add machinery for showing inheritance paths.

[sod] / src / class-utilities.lisp

;;; -*-lisp-*-
;;;
;;; A collection of utility functions for SOD classes
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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)

;;;--------------------------------------------------------------------------
;;; Finding things by name

(export 'find-superclass-by-nick)
(defun find-superclass-by-nick (class nick)
  "Returns the superclass of CLASS with nickname NICK, or signals an error."

  ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
  ;; trundle through its superclasses and hope for the best.
  (if (string= nick (sod-class-nickname class))
      class
      (or (some (lambda (super)
		  (find nick (sod-class-precedence-list super)
			:key #'sod-class-nickname
			:test #'string=))
		(sod-class-direct-superclasses class))
	  (error "No superclass of `~A' with nickname `~A'" class nick))))

(export '(find-instance-slot-by-name find-class-slot-by-name
	  find-message-by-name))
(flet ((find-thing-by-name (what class list name key)
	 (or (find name list :key key :test #'string=)
	     (error "No ~A in class `~A' with name `~A'" what class name))))

  (defun find-instance-slot-by-name (class super-nick slot-name)
    (let ((super (find-superclass-by-nick class super-nick)))
      (find-thing-by-name "instance slot" super (sod-class-slots super)
			  slot-name #'sod-slot-name)))

  (defun find-class-slot-by-name (class super-nick slot-name)
    (let* ((meta (sod-class-metaclass class))
	   (super (find-superclass-by-nick meta super-nick)))
      (find-thing-by-name "class slot" super (sod-class-slots super)
			  slot-name #'sod-slot-name)))

  (defun find-message-by-name (class super-nick message-name)
    (let ((super (find-superclass-by-nick class super-nick)))
      (find-thing-by-name "message" super (sod-class-messages super)
			  message-name #'sod-message-name))))

;;;--------------------------------------------------------------------------
;;; Describing class inheritance paths in diagnostics.

(export 'inheritance-path-reporter-state)
(defclass inheritance-path-reporter-state ()
  ((%class :type sod-class :initarg :class)
   (paths :type list :initarg :paths)
   (seen :type hash-table :initform (make-hash-table))))

(export 'make-inheritance-path-reporter-state)
(defun make-inheritance-path-reporter-state (class)
  (make-instance 'inheritance-path-reporter-state :class class))

(export 'report-inheritance-path)
(defun report-inheritance-path (state super)
  "Issue informational messages showing how CLASS inherits from SUPER."
  (with-slots (paths (class %class) include-boundary seen) state
    (unless (slot-boundp state 'paths)
      (setf paths (distinguished-point-shortest-paths
		   class
		   (lambda (c)
		     (mapcar (lambda (super) (cons super 1))
			     (sod-class-direct-superclasses c))))))
    (dolist (hop (mapcon (lambda (subpath)
			   (let ((super (car subpath))
				 (sub (and (cdr subpath)
					   (cadr subpath))))
			     (if (or (not sub) (gethash super seen))
				 nil
				 (progn
				   (setf (gethash super seen) t)
				   (list (cons super sub))))))
			 (cdr (find super paths :key #'cadr))))
      (let ((super (car hop))
	    (sub (cdr hop)))
	(info-with-location sub
			    "Class `~A' is a direct superclass ~
			     of `~A', defined here"
			    super sub)))))

;;;--------------------------------------------------------------------------
;;; Miscellaneous useful functions.

(export 'sod-subclass-p)
(defun sod-subclass-p (class-a class-b)
  "Return whether CLASS-A is a descendent of CLASS-B.

   Careful!  Assumes that the class precedence list of CLASS-A has been
   computed!"
  (member class-b (sod-class-precedence-list class-a)))

(export 'valid-name-p)
(defun valid-name-p (name)
  "Checks whether NAME is a valid name.

   The rules are:

     * the name must be a string
     * which is nonempty
     * whose first character is alphabetic
     * all of whose characters are alphanumeric or underscores
     * and which doesn't contain two consecutive underscores."

  (and (stringp name)
       (plusp (length name))
       (alpha-char-p (char name 0))
       (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
       (not (search "__" name))))

(export 'find-root-superclass)
(defun find-root-superclass (class)
  "Returns the `root' superclass of CLASS.

   The root superclass is the superclass which itself has no direct
   superclasses.  In universes not based on the provided builtin module, the
   root class may not be our beloved `SodObject'; however, there must be one
   (otherwise the class graph is cyclic, which should be forbidden), and we
   insist that it be unique."

  ;; The root superclass must be a chain head since the chains partition the
  ;; superclasses; the root has no superclasses so it can't have a link and
  ;; must therefore be a head.  This narrows the field down quite a lot.
  ;;
  ;; Note!  This function gets called from `check-sod-class' before the
  ;; class's chains have been computed.  Therefore we iterate over the direct
  ;; superclasses' chains rather than the class's own.  This misses a chain
  ;; only in the case where the class is its own chain head.  There are two
  ;; subcases: if there are no direct superclasses at all, then the class is
  ;; its own root; otherwise, it clearly can't be the root and the omission
  ;; is harmless.

  (let* ((supers (sod-class-direct-superclasses class))
	 (roots (if supers
		    (remove-duplicates
		     (remove-if #'sod-class-direct-superclasses
				(mappend (lambda (super)
					   (mapcar (lambda (chain)
						     (sod-class-chain-head
						      (car chain)))
						   (sod-class-chains super)))
					 supers)))
		    (list class))))
    (cond ((null roots) (error "Class ~A has no root class!" class))
	  ((cdr roots) (error "Class ~A has multiple root classes ~
			       ~{~A~#[~; and ~;, ~]~}"
			      class roots))
	  (t (car roots)))))

(export 'find-root-metaclass)
(defun find-root-metaclass (class)
  "Returns the `root' metaclass of CLASS.

   The root metaclass is the metaclass of the root superclass -- see
   `find-root-superclass'."
  (sod-class-metaclass (find-root-superclass class)))

;;;--------------------------------------------------------------------------
;;; Type hacking.

(export 'argument-lists-compatible-p)
(defun argument-lists-compatible-p (message-args method-args)
  "Compare argument lists for compatibility.

   Return true if METHOD-ARGS is a suitable method argument list
   corresponding to the message argument list MESSAGE-ARGS.  This is the case
   if the lists are the same length, each message argument has a
   corresponding method argument with the same type, and if the message
   arguments end in an ellpisis, the method arguments must end with a
   `va_list' argument.  (We can't pass actual variable argument lists around,
   except as `va_list' objects, which are devilish inconvenient things and
   require much hacking.  See the method combination machinery for details.)"

  (and (= (length message-args) (length method-args))
       (every (lambda (message-arg method-arg)
		(if (eq message-arg :ellipsis)
		    (c-type-equal-p (argument-type method-arg)
				    c-type-va-list)
		    (c-type-equal-p (argument-type message-arg)
				    (argument-type method-arg))))
	      message-args method-args)))

;;;--------------------------------------------------------------------------
;;; Names of things.

(export 'islots-struct-tag)
(defun islots-struct-tag (class)
  (format nil "~A__islots" class))

(export 'ichain-struct-tag)
(defun ichain-struct-tag (class chain-head)
  (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))

(export 'ichain-union-tag)
(defun ichain-union-tag (class chain-head)
  (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))

(export 'ilayout-struct-tag)
(defun ilayout-struct-tag (class)
  (format nil "~A__ilayout" class))

(export 'vtmsgs-struct-tag)
(defun vtmsgs-struct-tag (class super)
  (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))

(export 'vtable-union-tag)
(defun vtable-union-tag (class chain-head)
  (format nil "~A__vtu_~A" class (sod-class-nickname chain-head)))

(export 'vtable-struct-tag)
(defun vtable-struct-tag (class chain-head)
  (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))

(export 'vtable-name)
(defun vtable-name (class chain-head)
  (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))

(export 'message-macro-name)
(defun message-macro-name (class entry)
  (format nil "~A_~A" class (method-entry-slot-name entry)))

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