Will someone with privileges please apply the attached patch (I also attach the full lisp file, should that be easier) to Lisp-Dep/fix-acl.lisp?
AFAICT, this should fix problems with defining the CLIM-MOP package for Allegro Common Lisp.
I don't see any downside to applying this patch, since some canvassing reveals that I'm the only person who will admit to using McCLIM with Allegro CL, so I will only be hurting myself if there's anything wrong! And I *might* be helping some future ACL user.
Index: fix-acl.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Lisp-Dep/fix-acl.lisp,v retrieving revision 1.9 diff -u -F^(def -r1.9 fix-acl.lisp --- fix-acl.lisp 21 Mar 2003 15:15:09 -0000 1.9 +++ fix-acl.lisp 3 Feb 2005 15:33:30 -0000 @@ -5,15 +5,117 @@ ;;; Needed to keep ACL from issuing warnings about toplevel (shadow ...) forms (setq comp:*cltl1-compile-file-toplevel-compatibility-p* nil)
-(require :loop) +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :loop) + (require :mop))
(defpackage :clim-mop - (:use :clos)) - + (:use :clos :common-lisp) + (:export "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "ALLOCATE-INSTANCE" + "BUILT-IN-CLASS" + "CLASS" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-NAME" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FORWARD-REFERENCED-CLASS" + "FUNCALLABLE-STANDARD-CLASS" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "FUNCALLABLE-STANDARD-OBJECT" + "FUNCTION" + "GENERIC-FUNCTION" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-INSTANCE" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METAOBJECT" + "METHOD" + "METHOD-COMBINATION" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-QUALIFIERS" + "METHOD-SPECIALIZERS" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-DEFINITION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-LOCATION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-WRITERS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-CLASS" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-GENERIC-FUNCTION" + "STANDARD-INSTANCE-ACCESS" + "STANDARD-METHOD" + "STANDARD-OBJECT" + "STANDARD-READER-METHOD" + "STANDARD-SLOT-DEFINITION" + "STANDARD-WRITER-METHOD" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS"))
-(eval-when (:compile-toplevel :load-toplevel :execute) - (do-external-symbols (sym :clos) - (export sym :clim-mop))) +;;;(eval-when (:compile-toplevel :load-toplevel :execute) +;;; (do-external-symbols (sym :clos) +;;; (export sym :clim-mop)))
(eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defclass)
;;; -*- Mode: Lisp; Package: User -*-
(in-package :common-lisp-user)
;;; Needed to keep ACL from issuing warnings about toplevel (shadow ...) forms (setq comp:*cltl1-compile-file-toplevel-compatibility-p* nil)
(eval-when (:compile-toplevel :load-toplevel :execute) (require :loop) (require :mop))
(defpackage :clim-mop (:use :clos :common-lisp) (:export "ACCESSOR-METHOD-SLOT-DEFINITION" "ADD-DEPENDENT" "ADD-DIRECT-METHOD" "ADD-DIRECT-SUBCLASS" "ADD-METHOD" "ALLOCATE-INSTANCE" "BUILT-IN-CLASS" "CLASS" "CLASS-DEFAULT-INITARGS" "CLASS-DIRECT-DEFAULT-INITARGS" "CLASS-DIRECT-SLOTS" "CLASS-DIRECT-SUBCLASSES" "CLASS-DIRECT-SUPERCLASSES" "CLASS-FINALIZED-P" "CLASS-NAME" "CLASS-PRECEDENCE-LIST" "CLASS-PROTOTYPE" "CLASS-SLOTS" "COMPUTE-APPLICABLE-METHODS" "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" "COMPUTE-CLASS-PRECEDENCE-LIST" "COMPUTE-DEFAULT-INITARGS" "COMPUTE-DISCRIMINATING-FUNCTION" "COMPUTE-EFFECTIVE-METHOD" "COMPUTE-EFFECTIVE-SLOT-DEFINITION" "COMPUTE-SLOTS" "DIRECT-SLOT-DEFINITION" "DIRECT-SLOT-DEFINITION-CLASS" "EFFECTIVE-SLOT-DEFINITION" "EFFECTIVE-SLOT-DEFINITION-CLASS" "ENSURE-CLASS" "ENSURE-CLASS-USING-CLASS" "ENSURE-GENERIC-FUNCTION" "ENSURE-GENERIC-FUNCTION-USING-CLASS" "EQL-SPECIALIZER" "EQL-SPECIALIZER-OBJECT" "EXTRACT-LAMBDA-LIST" "EXTRACT-SPECIALIZER-NAMES" "FINALIZE-INHERITANCE" "FIND-METHOD-COMBINATION" "FORWARD-REFERENCED-CLASS" "FUNCALLABLE-STANDARD-CLASS" "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" "FUNCALLABLE-STANDARD-OBJECT" "FUNCTION" "GENERIC-FUNCTION" "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" "GENERIC-FUNCTION-DECLARATIONS" "GENERIC-FUNCTION-LAMBDA-LIST" "GENERIC-FUNCTION-METHOD-CLASS" "GENERIC-FUNCTION-METHOD-COMBINATION" "GENERIC-FUNCTION-METHODS" "GENERIC-FUNCTION-NAME" "INTERN-EQL-SPECIALIZER" "MAKE-INSTANCE" "MAKE-METHOD-LAMBDA" "MAP-DEPENDENTS" "METAOBJECT" "METHOD" "METHOD-COMBINATION" "METHOD-FUNCTION" "METHOD-GENERIC-FUNCTION" "METHOD-LAMBDA-LIST" "METHOD-QUALIFIERS" "METHOD-SPECIALIZERS" "READER-METHOD-CLASS" "REMOVE-DEPENDENT" "REMOVE-DIRECT-METHOD" "REMOVE-DIRECT-SUBCLASS" "REMOVE-METHOD" "SET-FUNCALLABLE-INSTANCE-FUNCTION" "SLOT-BOUNDP-USING-CLASS" "SLOT-DEFINITION" "SLOT-DEFINITION-ALLOCATION" "SLOT-DEFINITION-INITARGS" "SLOT-DEFINITION-INITFORM" "SLOT-DEFINITION-INITFUNCTION" "SLOT-DEFINITION-LOCATION" "SLOT-DEFINITION-NAME" "SLOT-DEFINITION-READERS" "SLOT-DEFINITION-TYPE" "SLOT-DEFINITION-WRITERS" "SLOT-MAKUNBOUND-USING-CLASS" "SLOT-VALUE-USING-CLASS" "SPECIALIZER" "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" "SPECIALIZER-DIRECT-METHODS" "STANDARD-ACCESSOR-METHOD" "STANDARD-CLASS" "STANDARD-DIRECT-SLOT-DEFINITION" "STANDARD-EFFECTIVE-SLOT-DEFINITION" "STANDARD-GENERIC-FUNCTION" "STANDARD-INSTANCE-ACCESS" "STANDARD-METHOD" "STANDARD-OBJECT" "STANDARD-READER-METHOD" "STANDARD-SLOT-DEFINITION" "STANDARD-WRITER-METHOD" "UPDATE-DEPENDENT" "VALIDATE-SUPERCLASS" "WRITER-METHOD-CLASS"))
;;;(eval-when (:compile-toplevel :load-toplevel :execute) ;;; (do-external-symbols (sym :clos) ;;; (export sym :clim-mop)))
(eval-when (:compile-toplevel :load-toplevel :execute) (export '(clim-lisp-patch::defclass) :clim-lisp-patch))
(defvar clim-lisp-patch::*compile-time-clos-names* (make-hash-table))
(defun clim-lisp-patch::compile-time-clos-class-p (name) (gethash name clim-lisp-patch::*compile-time-clos-names* nil))
(defmacro clim-lisp-patch:defclass (name &rest args) `(progn (eval-when (:compile-toplevel) (setf (gethash ',name clim-lisp-patch::*compile-time-clos-names*) t)) (cl:defclass ,name ,@args)))
#+nil (progn (eval-when (:compile-toplevel :load-toplevel :execute) (defvar clim-lisp-patch::*inline-functions* nil))
(defmacro clim-lisp-patch:declaim (&rest args) (dolist (arg args) (cond ((and (consp arg) (eq (car arg) 'inline)) (dolist (k (cdr arg)) (pushnew k clim-lisp-patch::*inline-functions*))))) `(declaim ,@args) )
(defmacro clim-lisp-patch:defun (fun args &body body) (cond ((member fun clim-lisp-patch::*inline-functions*) (cond ((and (consp fun) (eq (car fun) 'setf)) (let ((fnam (intern (concatenate 'string "(SETF " (symbol-name (cadr fun)) ")") (symbol-package (cadr fun))))) `(progn (defsetf ,(cadr fun) (&rest ap) (new-value) (list* ',fnam new-value ap)) (defun ,fnam ,args .,body) (define-compiler-macro ,fnam (&rest .args.) (cons '(lambda ,args .,body) .args.))))) (t `(progn (defun ,fun ,args .,body) (define-compiler-macro ,fun (&rest .args.) (cons '(lambda ,args .,body) .args.)))))) (t `(defun ,fun ,args ,@body)))) )