From f77ae3730973ff43cef47039f6b34731024dc8ba Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sun, 20 Jun 2010 18:38:55 +0200 Subject: [PATCH] Reimplemented CLOS dependents so that they can be used for bootstrapping --- src/clos/fixup.lsp | 44 ++++++++++++++++++++++++++++++++++++------ src/clos/generic.lsp | 7 +++++-- src/clos/kernel.lsp | 16 ++++++++++++++- src/clos/standard.lsp | 17 ---------------- src/clos/stdmethod.lsp | 16 --------------- 5 files changed, 58 insertions(+), 42 deletions(-) diff --git a/src/clos/fixup.lsp b/src/clos/fixup.lsp index d46676465..480911011 100644 --- a/src/clos/fixup.lsp +++ b/src/clos/fixup.lsp @@ -202,12 +202,17 @@ their lambda lists ~A and ~A are not congruent." ;; gf) -(setf (method-function - (eval '(defmethod false-add-method ((gf standard-generic-function) - (method standard-method))))) - #'add-method) -(setf (fdefinition 'add-method) #'false-add-method) -(setf (generic-function-name #'add-method) 'add-method) +(defun function-to-method (name signature) + (let* ((aux-name 'temp-method) + (method (eval `(defmethod ,aux-name ,signature))) + (generic-function (fdefinition aux-name))) + (setf (method-function method) (fdefinition name)) + (setf (fdefinition name) generic-function) + (setf (generic-function-name generic-function) name) + (fmakunbound aux-name))) + +(function-to-method 'add-method '((gf standard-generic-function) + (method standard-method))) (defun remove-method (gf method) (setf (generic-function-methods gf) @@ -249,3 +254,30 @@ their lambda lists ~A and ~A are not congruent." (t (error "~A is not a class." new-value)))) new-value) ) + +;;; ---------------------------------------------------------------------- +;;; DEPENDENT MAINTENANCE PROTOCOL +;;; + +(function-to-method 'map-dependents '((c standard-generic-function) function)) + +(defmethod map-dependents ((c class) function) + (dolist (d (class-dependents c)) + (funcall function c))) + +(function-to-method 'add-dependent '((c standard-generic-function) function)) + +(defmethod add-dependent ((c class) dep) + (pushnew c (class-dependents c))) + +(defmethod remove-dependent ((c standard-generic-function) dep) + (setf (generic-function-dependents c) + (remove dep (generic-function-dependents c)))) + +(defmethod remove-dependent ((c class) dep) + (setf (class-dependents c) + (remove dep (class-dependents c)))) + +(defgeneric update-dependents (object dependents &rest initargs)) + +(setf *clos-booted* t) diff --git a/src/clos/generic.lsp b/src/clos/generic.lsp index 0e7a8e4d0..f68a9aa02 100644 --- a/src/clos/generic.lsp +++ b/src/clos/generic.lsp @@ -244,6 +244,9 @@ (simple-program-error "The special operator ~A is not a valid name for a generic function" name)) ((macro-function name) (simple-program-error "The symbol ~A is bound to a macro and is not a valid name for a generic function" name)) + ((not *clos-booted*) + (setf (fdefinition (or traced name)) + (apply #'ensure-generic-function-using-class nil name args)) + (fdefinition name)) (t - (simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name)) - ))) + (simple-program-error "The symbol ~A is bound to an ordinary function and is not a valid name for a generic function" name))))) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 54cb31e09..32c2e2f70 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -16,6 +16,8 @@ (in-package "CLOS") +(defparameter *clos-booted* nil) + (defconstant *default-method-cache-size* 64 "Size of hash tables for methods") ;;;---------------------------------------------------------------------- @@ -79,7 +81,8 @@ (size :accessor class-size) (sealedp :initarg :sealedp :initform nil :accessor class-sealedp) (prototype) - (dependents :initform nil :accessor class-dependents)))) + (dependents :initform nil :accessor class-dependents) + (valid-initargs :initform nil :accessor class-valid-initargs)))) ;#.(create-accessors +class-slots+ 'class) @@ -207,6 +210,17 @@ ;;; ---------------------------------------------------------------------- ;;; early versions +(defun map-dependents (c function) + (dolist (d (if (classp c) + (class-dependents c) + (generic-function-dependents c))) + (funcall function d))) + +(defun add-dependent (c d) + (if (classp c) + (pushnew d (class-dependents c)) + (pushnew d (generic-function-dependents c)))) + ;;; early version used during bootstrap (defun ensure-generic-function (name &key (lambda-list (si::unbound) l-l-p)) (if (and (fboundp name) (si::instancep (fdefinition name))) diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp index 0bcf716f8..adf12b9a1 100644 --- a/src/clos/standard.lsp +++ b/src/clos/standard.lsp @@ -77,23 +77,6 @@ ))) instance) -;;; ---------------------------------------------------------------------- -;;; DEPENDENT MAINTENANCE PROTOCOL -;;; - -(defmethod map-dependents ((c class) function) - (print 'map-dependents) - (print (length (class-dependents c))) - (dolist (d (class-dependents c)) - (funcall function c))) - -(defmethod add-dependent ((c class) dep) - (pushnew c (class-dependents c))) - -(defmethod remove-dependent ((c class) dep) - (setf (class-dependents c) - (remove dep (class-dependents c)))) - ;;; ---------------------------------------------------------------------- ;;; CLASSES INITIALIZATION AND REINITIALIZATION ;;; diff --git a/src/clos/stdmethod.lsp b/src/clos/stdmethod.lsp index 617efb11f..1ee565648 100644 --- a/src/clos/stdmethod.lsp +++ b/src/clos/stdmethod.lsp @@ -28,21 +28,6 @@ #.(remove-accessors +standard-generic-function-slots+) (:metaclass 'funcallable-standard-class)) -;;; -;;; GENERIC-FUNCTION DEPENDENT MAINTENANCE PROTOCOL -;;; - -(defmethod map-dependents ((c standard-generic-function) function) - (dolist (d (generic-function-dependents c)) - (funcall function c))) - -(defmethod add-dependent ((c standard-generic-function) dep) - (pushnew c (generic-function-dependents c))) - -(defmethod remove-dependent ((c standard-generic-function) dep) - (setf (generic-function-dependents c) - (remove dep (generic-function-dependents c)))) - ;;;---------------------------------------------------------------------- ;;; Method ;;; ---------------------------------------------------------------------- @@ -71,4 +56,3 @@ (defclass standard-reader-method (standard-accessor-method) ()) (defclass standard-writer-method (standard-accessor-method) ()) -