[Top][All Lists]
[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)
- [Gcl-devel] Patch to clcs/install.lisp,
Paul F. Dietz <=