← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to clcs/clcs_install.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/clcs_install.lisp
 
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)))))