gcl-devel
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

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


From: Paul F. Dietz
Subject: [Gcl-devel] Patch to clcs/install.lisp
Date: Mon, 02 Dec 2002 19:12:51 -0600
User-agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.2) Gecko/20021126

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)





reply via email to

[Prev in Thread] Current Thread [Next in Thread]