;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; 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
;; Superclass Linearization for Dylan' for more detail.
;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
+;;; Utilities.
+
+(export 'merge-class-lists)
+(defun merge-class-lists (lists pick)
+ "Merge the LISTS of classes, using PICK to break ties.
+
+ This is a convenience wrapper around the main `merge-lists' function.
+ Given that class linearizations (almost?) always specify a custom
+ tiebreaker function, this isn't a keyword argument. Also, this wrapper
+ provides a standard presentation function so that any errors are presented
+ properly."
+ (merge-lists lists
+ :pick pick
+ :present (lambda (class)
+ (format nil "`~A'" (sod-class-name class)))))
+
;;; Tiebreaker functions.
(defun clos-tiebreaker (candidates so-far)
(when (member candidate (sod-class-direct-superclasses class))
(setf winner candidate))))
(unless winner
- (error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
+ (error "SOD INTERNAL ERROR: Failed to break tie in CLOS"))
winner))
(defun c3-tiebreaker (candidates cpls)
(dolist (candidate candidates)
(when (member candidate cpl)
(return-from c3-tiebreaker candidate))))
- (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
+ (error "SOD INTERNAL ERROR: Failed to break tie in C3"))
;;; Linearization functions.
+(export 'clos-cpl)
(defun clos-cpl (class)
"Compute the class precedence list of CLASS using CLOS linearization rules.
(remove-duplicates (cons class
(mappend #'superclasses
direct-supers))))))
- (merge-lists (mapcar (lambda (class)
- (cons class
- (sod-class-direct-superclasses class)))
- (superclasses class))
- :pick #'clos-tiebreaker)))
+ (merge-class-lists
+ (mapcar (lambda (class)
+ (cons class (sod-class-direct-superclasses class)))
+ (superclasses class))
+ #'clos-tiebreaker)))
+(export 'dylan-cpl)
(defun dylan-cpl (class)
"Compute the class precedence list of CLASS using Dylan linearization
rules.
you're going to lose anyway."
(let ((direct-supers (sod-class-direct-superclasses class)))
- (merge-lists (cons (cons class direct-supers)
- (mapcar #'sod-class-precedence-list direct-supers))
- :pick #'clos-tiebreaker)))
+ (merge-class-lists
+ (cons (cons class direct-supers)
+ (mapcar #'sod-class-precedence-list direct-supers))
+ #'clos-tiebreaker)))
+(export 'c3-cpl)
(defun c3-cpl (class)
"Compute the class precedence list of CLASS using C3 linearization rules.
(let* ((direct-supers (sod-class-direct-superclasses class))
(cpls (mapcar #'sod-class-precedence-list direct-supers)))
- (merge-lists (cons (cons class direct-supers) cpls)
- :pick (lambda (candidates so-far)
+ (merge-class-lists (cons (cons class direct-supers) cpls)
+ (lambda (candidates so-far)
(declare (ignore so-far))
(c3-tiebreaker candidates cpls)))))
+(export 'flavors-cpl)
(defun flavors-cpl (class)
"Compute the class precedence list of CLASS using Flavors linearization
rules.
(walk class)
(nreverse done))))
+(export 'python-cpl)
(defun python-cpl (class)
"Compute the class precedence list of CLASS using the documented Python 2.2
linearization rules.
(walk class)
(delete-duplicates (nreverse done)))))
+(export 'l*loops-cpl)
(defun l*loops-cpl (class)
"Compute the class precedence list of CLASS using L*LOOPS linearization
rules.
precedence order i.e., the direct-superclasses list orderings."
(let ((dfs (flavors-cpl class)))
- (cons class (merge-lists (mapcar #'sod-class-precedence-list
+ (cons class
+ (merge-class-lists (mapcar #'sod-class-precedence-list
(sod-class-direct-superclasses class))
- :pick (lambda (candidates so-far)
- (declare (ignore so-far))
- (dolist (class dfs)
- (when (member class candidates)
- (return class))))))))
+ (lambda (candidates so-far)
+ (declare (ignore so-far))
+ (dolist (class dfs)
+ (when (member class candidates)
+ (return class))))))))
;;; Default function.
(gethash super table))
(cdr class-precedence-list)))))))))
+;;;--------------------------------------------------------------------------
+;;; Metaclasses.
+
+(defun maximum (items order what)
+ "Return a maximum item according to the non-strict partial ORDER."
+ (reduce (lambda (best this)
+ (cond ((funcall order best this) best)
+ ((funcall order this best) this)
+ (t (error "Unable to choose best ~A" what))))
+ items))
+
+(defmethod guess-metaclass ((class sod-class))
+ "Default metaclass-guessing function for classes.
+
+ Return the most specific metaclass of any of the CLASS's direct
+ superclasses."
+
+ ;; During bootstrapping, our superclasses might not have their own
+ ;; metaclasses resolved yet. If we find this, then throw `bootstrapping'
+ ;; so that `shared-initialize' on `sod-class' can catch it (or as a shot
+ ;; across the bows of anyone else who calls us).
+ (maximum (mapcar (lambda (super)
+ (if (slot-boundp super 'metaclass)
+ (slot-value super 'metaclass)
+ (throw 'bootstrapping nil)))
+ (sod-class-direct-superclasses class))
+ #'sod-subclass-p
+ (format nil "metaclass for `~A'" class)))
+
;;;--------------------------------------------------------------------------
;;; Sanity checking.
(error "In `~A~, chain-to class `~A' is not a proper superclass"
class chain-link)))
+ ;; Check that the initargs declare compatible types. Duplicate entries,
+ ;; even within a class, are harmless, but at most one initarg in any
+ ;; class should declare a default value.
+ (with-slots (class-precedence-list) class
+ (let ((seen (make-hash-table :test #'equal)))
+ (dolist (super class-precedence-list)
+ (with-slots (initargs) super
+ (dolist (initarg (reverse initargs))
+ (let* ((initarg-name (sod-initarg-name initarg))
+ (initarg-type (sod-initarg-type initarg))
+ (initarg-default (sod-initarg-default initarg))
+ (found (gethash initarg-name seen))
+ (found-type (and found (sod-initarg-type found)))
+ (found-default (and found (sod-initarg-default found)))
+ (found-class (and found (sod-initarg-class found)))
+ (found-location (and found (file-location found))))
+ (with-default-error-location (initarg)
+ (cond ((not found)
+ (setf (gethash initarg-name seen) initarg))
+ ((not (c-type-equal-p initarg-type found-type))
+ (cerror* "Inititalization argument `~A' defined ~
+ with incompatible types: ~
+ ~A in class ~A, and ~
+ ~A in class ~A (at ~A)"
+ initarg-name initarg-type super
+ found-type found-class found-location))
+ ((and initarg-default found-default
+ (eql super found-class))
+ (cerror* "Initialization argument `~A' redefined ~
+ with default value ~
+ (previous definition at ~A)"
+ initarg-name found-location))
+ (initarg-default
+ (setf (gethash initarg-name seen) initarg))))))))))
+
;; Check for circularity in the superclass graph. Since the superclasses
;; should already be acyclic, it suffices to check that our class is not
;; a superclass of any of its own direct superclasses.
((nil)
;; If this fails, mark the class as a loss.
- (setf (sod-class-state class) :broken)
+ (setf (slot-value class 'state) :broken)
+
+ ;; Set up the metaclass if it's not been set already. This is delayed
+ ;; to give bootstrapping a chance to set up metaclass and superclass
+ ;; circularities.
+ (default-slot (class 'metaclass) (guess-metaclass class))
;; Finalize all of the superclasses. There's some special pleading
;; here to make bootstrapping work: we don't try to finalize the
(finalize-sod-class metaclass)))
;; Stash the class's type.
- (setf (sod-class-type class)
+ (setf (slot-value class '%type)
(make-class-type (sod-class-name class)))
;; Clobber the lists of items if they've not been set.
(setf (values chain-head chain chains) (compute-chains class)))
;; Done.
- (setf (sod-class-state class) :finalized)
+ (setf (slot-value class 'state) :finalized)
t)
(:broken
(:finalized
t))))
-(macrolet ((define-layout-slot (slot (class) &body body)
- `(define-on-demand-slot sod-class ,slot (,class)
- (check-class-is-finalized ,class)
- ,@body)))
- (flet ((check-class-is-finalized (class)
- (unless (eq (sod-class-state class) :finalized)
- (error "Class ~S is not finalized" class))))
- (define-layout-slot %ilayout (class)
- (compute-ilayout class))
- (define-layout-slot effective-methods (class)
- (compute-effective-methods class))
- (define-layout-slot vtables (class)
- (compute-vtables class))))
-
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff