Re: [Gcl-devel] Patch to clcs/install.lisp

[Camm Maguire]

Thanks Paul!  Its in.

Take care,

"Paul F. Dietz" <address@hidden> writes:

> Here's a patch to clcs/install.lisp that gets around some of the problems
> with keyword properties on CL symbols.  The patch replaces the property
> :definition-before-clcs with definition-before-clcs, which is legal.
> 
> Index: clcs/install.lisp
> ===================================================================
> RCS file: /cvsroot/gcl/gcl/clcs/install.lisp,v
> retrieving revision 1.3
> diff -c -r1.3 install.lisp
> *** clcs/install.lisp 24 Sep 2002 15:00:30 -0000      1.3
> --- clcs/install.lisp 3 Dec 2002 01:07:51 -0000
> ***************
> *** 6,13 ****
>      '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE 
> CCASE))
> 
>    (defun install-symbol (real clcs)
> !   (unless (get real ':definition-before-clcs)
> !     (setf (get real ':definition-before-clcs)
>         (symbol-function real)))
>      (unless (eq (symbol-function real)
>             (symbol-function clcs))   
> --- 6,13 ----
>      '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE 
> CCASE))
> 
>    (defun install-symbol (real clcs)
> !   (unless (get real 'definition-before-clcs)
> !     (setf (get real 'definition-before-clcs)
>         (symbol-function real)))
>      (unless (eq (symbol-function real)
>             (symbol-function clcs))   
> ***************
> *** 15,25 ****
>         (symbol-function clcs))))
> 
>    (defun revert-symbol (real)
> !   (when (and (get real ':definition-before-clcs)
>            (not (eq (symbol-function real)
> !                   (get real ':definition-before-clcs))))
>        (setf (symbol-function real)
> !       (get real ':definition-before-clcs))))
> 
>    (defvar *clcs-redefinitions*
>      (nconc (mapcar #'(lambda (symbol)
> --- 15,25 ----
>         (symbol-function clcs))))
> 
>    (defun revert-symbol (real)
> !   (when (and (get real 'definition-before-clcs)
>            (not (eq (symbol-function real)
> !                   (get real 'definition-before-clcs))))
>        (setf (symbol-function real)
> !       (get real 'definition-before-clcs))))
> 
>    (defvar *clcs-redefinitions*
>      (nconc (mapcar #'(lambda (symbol)
> ***************
> *** 48,54 ****
>    (defun clcs-compile-file (file &rest args)
>      (loop (with-simple-restart (retry "Retry compiling file ~S." file)
>         (let ((values (multiple-value-list
> !                         (apply (or (get 'compile-file 
> ':definition-before-clcs)
>                                      #'compile-file)
>                                  file args))))
>           (unless #+kcl compiler::*error-p* #-kcl nil
> --- 48,54 ----
>    (defun clcs-compile-file (file &rest args)
>      (loop (with-simple-restart (retry "Retry compiling file ~S." file)
>         (let ((values (multiple-value-list
> !                         (apply (or (get 'compile-file 
> 'definition-before-clcs)
>                                      #'compile-file)
>                                  file args))))
>           (unless #+kcl compiler::*error-p* #-kcl nil
> ***************
> *** 59,65 ****
>    (defun clcs-compile (&rest args)
>      (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
>         (let ((values (multiple-value-list
> !                         (apply (or (get 'compile ':definition-before-clcs)
>                                      #'compile-file)
>                                  args))))
>           (unless #+kcl compiler::*error-p* #-kcl nil
> --- 59,65 ----
>    (defun clcs-compile (&rest args)
>      (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
>         (let ((values (multiple-value-list
> !                         (apply (or (get 'compile 'definition-before-clcs)
>                                      #'compile-file)
>                                  args))))
>           (unless #+kcl compiler::*error-p* #-kcl nil
> ***************
> *** 70,82 ****
>    (defun clcs-load (file &rest args)
>      (loop (with-simple-restart (retry "Retry loading file ~S." file)
>              (return-from clcs-load
> !                        (apply (or (get 'load ':definition-before-clcs) 
> #'load)
>                                  file args)))))
> 
>    (defun clcs-open (file &rest args)
>      (loop (with-simple-restart (retry "Retry opening file ~S." file)
>              (return-from clcs-open
> !                        (apply (or (get 'open ':definition-before-clcs) 
> #'open)
>                                  file args)))))
> 
>    #+(or kcl lucid cmu)
> --- 70,82 ----
>    (defun clcs-load (file &rest args)
>      (loop (with-simple-restart (retry "Retry loading file ~S." file)
>              (return-from clcs-load
> !                        (apply (or (get 'load 'definition-before-clcs) 
> #'load)
>                                  file args)))))
> 
>    (defun clcs-open (file &rest args)
>      (loop (with-simple-restart (retry "Retry opening file ~S." file)
>              (return-from clcs-open
> !                        (apply (or (get 'open 'definition-before-clcs) 
> #'open)
>                                  file args)))))
> 
>    #+(or kcl lucid cmu)
> 
> 
> 
> _______________________________________________
> Gcl-devel mailing list
> address@hidden
> http://mail.gnu.org/mailman/listinfo/gcl-devel
> 
> 

-- 
Camm Maguire                                            address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah