X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3dca7758421664a838c54b273bd9221f02072045..2ef055fe6ca5f97b0f3d57ad3675e4ac09210266:/src/class-finalize-impl.lisp diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 9c34bd7..be42f13 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -100,6 +100,7 @@ ;;; Linearization functions. +(export 'clos-cpl) (defun clos-cpl (class) "Compute the class precedence list of CLASS using CLOS linearization rules. @@ -122,6 +123,7 @@ (superclasses class)) :pick #'clos-tiebreaker))) +(export 'dylan-cpl) (defun dylan-cpl (class) "Compute the class precedence list of CLASS using Dylan linearization rules. @@ -145,6 +147,7 @@ (mapcar #'sod-class-precedence-list direct-supers)) :pick #'clos-tiebreaker))) +(export 'c3-cpl) (defun c3-cpl (class) "Compute the class precedence list of CLASS using C3 linearization rules. @@ -164,6 +167,7 @@ (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. @@ -186,6 +190,7 @@ (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. @@ -205,6 +210,7 @@ (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. @@ -270,6 +276,35 @@ (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. (defmethod check-sod-class ((class sod-class)) @@ -308,6 +343,41 @@ (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. @@ -344,7 +414,12 @@ ((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 @@ -360,7 +435,7 @@ (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. @@ -382,7 +457,7 @@ (setf (values chain-head chain chains) (compute-chains class))) ;; Done. - (setf (sod-class-state class) :finalized) + (setf (slot-value class 'state) :finalized) t) (:broken @@ -391,13 +466,13 @@ (: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)))) +(flet ((check-class-is-finalized (class) + (unless (eq (sod-class-state class) :finalized) + (error "Class ~S is not finalized" class)))) + (macrolet ((define-layout-slot (slot (class) &body body) + `(define-on-demand-slot sod-class ,slot (,class) + (check-class-is-finalized ,class) + ,@body))) (define-layout-slot %ilayout (class) (compute-ilayout class)) (define-layout-slot effective-methods (class)