--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; A collection of utility functions for SOD classes
+;;;
+;;; (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)
+
+;;;--------------------------------------------------------------------------
+;;; 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 "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 "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))))
+
+;;;--------------------------------------------------------------------------
+;;; 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
+ ;; superclass's 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)
+ (eq 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-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)))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff