diff --git a/pcl/info.lisp b/pcl/info.lisp index 377349a0a127f890e8ae28765b331425e8f1fd82..2ca5ba3d95924a68c43900399acaadb56829ed6a 100644 --- a/pcl/info.lisp +++ b/pcl/info.lisp @@ -36,7 +36,7 @@ ;;; GF is actually non-accessor GF. Clean this up. ;;; (setf symbol-value) should be handled like (setf fdefinition) -(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.6 2003/05/20 20:08:04 gerd Exp $") +(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.7 2003/05/27 11:49:57 gerd Exp $") (in-package "PCL") @@ -521,15 +521,73 @@ (setq body (cdr body))) (values outer-decls inner-decls body))) -;;; -;;; Set up SLOTS, AUTO-COMPILE, and NOT-AUTO-COMPILE as a recognizable -;;; declaration. -;;; -(declaim (declaration slots auto-compile not-auto-compile)) + +;;;; ******************************** +;;;; Adding New Declarations ******* +;;;; ******************************** + +(eval-when (compile load eval) + (defvar *declaration-handlers* ()) + + (defun %define-declaration (decl-name handler-name) + (let ((entry (assoc decl-name *declaration-handlers*))) + (if entry + (setf (cdr entry) handler-name) + (setq *declaration-handlers* + (acons decl-name handler-name *declaration-handlers*)))))) + +(defmacro define-declaration (decl-name lambda-list &body body) + (let ((handler-name (symbolicate 'handle- decl-name '-declaration))) + `(eval-when (compile load eval) + (declaim (declaration ,decl-name)) + (defun ,handler-name ,lambda-list ,@body) + (%define-declaration ',decl-name ',handler-name)))) + +(defun proclamation-hook (form) + (when (consp form) + (let ((handler (cdr (assoc (car form) *declaration-handlers*)))) + (when handler + (funcall handler form))))) + +(pushnew 'proclamation-hook c::*proclamation-hooks*) + + +;;;; *************************** +;;;; SLOTS declaration ******** +;;;; *************************** + (pushnew 'slots *variable-declarations-with-argument*) (pushnew 'slots walker:*variable-declarations*) -(defvar *auto-compile-global-default* nil) +(define-declaration slots (form) + (flet ((invalid (&optional subform) + (if subform + (warn "~@<Invalid slot access specifier ~s in ~s.~@:>" + subform form) + (warn "~@<Invalid slot access declaration ~s.~@:>" + form)))) + (dolist (specifier (cdr form)) + (if (and (consp specifier) + (memq (car specifier) *slots-qualities*)) + (dolist (class-entry (cdr specifier)) + (let (class slots) + (typecase class-entry + (symbol + (setq class class-entry)) + (cons + (setq class (car class-entry)) + (setq slots (cdr class-entry))) + (t + (invalid specifier))) + (when class + (let* ((info (class-info-or-make class)) + (entry (assoc (car specifier) + (class-info-slot-access info)))) + (if entry + (setf (cdr entry) slots) + (push (list* (car specifier) slots) + (class-info-slot-access info))))))) + (invalid))))) ;;; ;;; True if there is a slot optimization declaration DECLARATION in @@ -589,42 +647,40 @@ (null (cdr spec)) (memq slot-name (cdr spec)))))) -(defun proclamation-hook (form) - (when (consp form) - (case (car form) - (slots (slot-access-proclamation form)) - (auto-compile (auto-compile-proclamation form t)) - (not-auto-compile (auto-compile-proclamation form nil))))) +(defun class-has-a-forward-referenced-superclass-p (class) + (or (forward-referenced-class-p class) + (some #'class-has-a-forward-referenced-superclass-p + (class-direct-superclasses class)))) + +;;; +;;; Return true if class CLASS-NAME should be defined at compile time. +;;; Called from EXPAND-DEFCLASS. ENV is the environment in which the +;;; DEFCLASS of CLASS-NAME appears. SUPERS is the list of superclass +;;; names for CLASS-NAME. +;;; +(defun define-class-at-compile-time-p (env class-name &optional supers) + (or (slot-declaration env 'inline class-name) + (some (lambda (super) + (let ((class (find-class super nil))) + (and class + (not (class-has-a-forward-referenced-superclass-p class)) + (some (lambda (c) + (slot-declaration env 'inline c)) + (class-precedence-list class))))) + supers))) -(defun slot-access-proclamation (form) - (flet ((invalid (&optional subform) - (if subform - (warn "~@<Invalid slot access specifier ~s in ~s.~@:>" - subform form) - (warn "~@<Invalid slot access declaration ~s.~@:>" - form)))) - (dolist (specifier (cdr form)) - (if (and (consp specifier) - (memq (car specifier) *slots-qualities*)) - (dolist (class-entry (cdr specifier)) - (let (class slots) - (typecase class-entry - (symbol - (setq class class-entry)) - (cons - (setq class (car class-entry)) - (setq slots (cdr class-entry))) - (t - (invalid specifier))) - (when class - (let* ((info (class-info-or-make class)) - (entry (assoc (car specifier) - (class-info-slot-access info)))) - (if entry - (setf (cdr entry) slots) - (push (list* (car specifier) slots) - (class-info-slot-access info))))))) - (invalid))))) + +;;;; ********************************* +;;;; AUTO-COMPILE declaration ******* +;;;; ********************************* + +(define-declaration auto-compile (form) + (auto-compile-proclamation form t)) + +(define-declaration not-auto-compile (form) + (auto-compile-proclamation form nil)) + +(defvar *auto-compile-global-default* nil) (defun auto-compile-proclamation (form compilep) (flet ((invalid (&optional subform) @@ -660,30 +716,6 @@ (t (invalid specifier))))))) -(pushnew 'proclamation-hook c::*proclamation-hooks*) - -(defun class-has-a-forward-referenced-superclass-p (class) - (or (forward-referenced-class-p class) - (some #'class-has-a-forward-referenced-superclass-p - (class-direct-superclasses class)))) - -;;; -;;; Return true if class CLASS-NAME should be defined at compile time. -;;; Called from EXPAND-DEFCLASS. ENV is the environment in which the -;;; DEFCLASS of CLASS-NAME appears. SUPERS is the list of superclass -;;; names for CLASS-NAME. -;;; -(defun define-class-at-compile-time-p (env class-name &optional supers) - (or (slot-declaration env 'inline class-name) - (some (lambda (super) - (let ((class (find-class super nil))) - (and class - (not (class-has-a-forward-referenced-superclass-p class)) - (some (lambda (c) - (slot-declaration env 'inline c)) - (class-precedence-list class))))) - supers))) - ;;; ;;; Return true if method with the given name, qualifiers, and ;;; specializers should be auto-compiled.