/[gcl]/gcl/clcs/gcl_clcs_install.lisp
ViewVC logotype

Diff of /gcl/clcs/gcl_clcs_install.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:54 2005 UTC revision 1.2 by camm, Sat May 7 02:52:28 2005 UTC
# Line 0  Line 1 
1    ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
2    
3    (in-package "CONDITIONS")
4    
5    (defvar *shadowed-symbols*
6      '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE))
7    
8    (defun install-symbol (real clcs)
9      (unless (get real 'definition-before-clcs)
10        (setf (get real 'definition-before-clcs)
11              (symbol-function real)))
12      (unless (eq (symbol-function real)
13                  (symbol-function clcs))          
14        (setf (symbol-function real)
15              (symbol-function clcs))))
16    
17    (defun revert-symbol (real)
18      (when (and (get real 'definition-before-clcs)
19                 (not (eq (symbol-function real)
20                          (get real 'definition-before-clcs))))
21        (setf (symbol-function real)
22              (get real 'definition-before-clcs))))
23    
24    (defvar *clcs-redefinitions*
25      (nconc (mapcar #'(lambda (symbol)
26                         (list (intern (symbol-name symbol) "LISP") symbol))
27                     *shadowed-symbols*)
28             '((compile-file clcs-compile-file)
29               (compile clcs-compile)
30               (load clcs-load)
31               (open clcs-open)
32               #+kcl (si::break-level si::clcs-break-level)
33               #+kcl (si::terminal-interrupt si::clcs-terminal-interrupt)
34               #+kcl (si::break-quit si::clcs-break-quit)
35               #+kcl (si::error-set clcs-error-set)
36               #+kcl (si::universal-error-handler clcs-universal-error-handler))))
37    
38    (defun install-clcs-symbols ()
39      (dolist (r *clcs-redefinitions*)
40        (install-symbol (first r) (second r)))
41      nil)
42    
43    (defun revert-clcs-symbols ()
44      (dolist (r (reverse *clcs-redefinitions*))
45        (revert-symbol (first r)))
46      nil)
47    
48    (defun clcs-compile-file (file &rest args)
49      (loop (with-simple-restart (retry "Retry compiling file ~S." file)
50              (let ((values (multiple-value-list
51                                (apply (or (get 'compile-file 'definition-before-clcs)
52                                           #'compile-file)
53                                       file args))))
54                (unless #+kcl compiler::*error-p* #-kcl nil
55                  (return-from clcs-compile-file
56                    (values-list values)))
57                (error "~S failed." 'compile-file)))))
58    
59    (defun clcs-compile (&rest args)
60      (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
61              (let ((values (multiple-value-list
62                                (apply (or (get 'compile 'definition-before-clcs)
63                                           #'compile-file)
64                                       args))))
65                (unless #+kcl compiler::*error-p* #-kcl nil
66                  (return-from clcs-compile
67                    (values-list values)))
68                (error "~S failed." 'compile)))))
69    
70    (defun clcs-load (file &rest args)
71      (loop (with-simple-restart (retry "Retry loading file ~S." file)
72              (return-from clcs-load
73                           (apply (or (get 'load 'definition-before-clcs) #'load)
74                                  file args)))))
75    
76    (defun clcs-open (file &rest args)
77      (loop (with-simple-restart (retry "Retry opening file ~S." file)
78              (return-from clcs-open
79                           (apply (or (get 'open 'definition-before-clcs) #'open)
80                                  file args)))))
81    
82    #+(or kcl lucid cmu)
83    (install-clcs-symbols)
84    
85    #+dsys
86    (defun dsys::retry-operation (function retry-string)
87      (loop (with-simple-restart (retry retry-string)
88              (return-from dsys::retry-operation
89                (funcall function)))))
90    
91    #+dsys
92    (defun dsys::operate-on-module (module initial-state system-operation)
93      (if (null dsys::*retry-operation-list*)
94          (dsys::operate-on-module1 module initial-state system-operation)
95          (let ((retry-operation (car (last dsys::*retry-operation-list*)))
96                (dsys::*retry-operation-list* (butlast dsys::*retry-operation-list*)))
97            (restart-bind ((retry
98                            #'(lambda (&rest ignore)
99                                (declare (ignore ignore))
100                                (funcall (car retry-operation)))
101                            :report-function
102                            #'(lambda (stream)
103                                (write-string (cdr retry-operation) stream))))
104               (dsys::operate-on-module module initial-state system-operation)))))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26