← Back to branch summary

~ubuntu-branches/ubuntu/vivid/gcl/vivid

« back to all changes in this revision

Viewing changes to clcs/restart.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2002-03-04 14:29:59 UTC
  • Revision ID: james.westby@ubuntu.com-20020304142959-dey14w08kr7lldu3
Tags: upstream-2.5.0.cvs20020219
Import upstream version 2.5.0.cvs20020219

Show diffs side-by-side

added added

removed removed

Lines of Context:
clcs/restart.lisp
 
1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
2
 
 
3
(IN-PACKAGE "CONDITIONS")
 
4
 
 
5
;;; Unique Ids
 
6
 
 
7
(DEFVAR *UNIQUE-ID-TABLE* (MAKE-HASH-TABLE))
 
8
(DEFVAR *UNIQUE-ID-COUNT* -1)
 
9
 
 
10
(DEFUN UNIQUE-ID (OBJ)
 
11
  "Generates a unique integer ID for its argument."
 
12
  (OR (GETHASH OBJ *UNIQUE-ID-TABLE*)
 
13
      (SETF (GETHASH OBJ *UNIQUE-ID-TABLE*) (INCF *UNIQUE-ID-COUNT*))))
 
14
 
 
15
;;; Miscellaneous Utilities
 
16
 
 
17
(EVAL-WHEN (EVAL COMPILE LOAD)
 
18
 
 
19
(DEFUN PARSE-KEYWORD-PAIRS (LIST KEYS)
 
20
  (DO ((L LIST (CDDR L))
 
21
       (K '() (LIST* (CADR L) (CAR L) K)))
 
22
      ((OR (NULL L) (NOT (MEMBER (CAR L) KEYS)))
 
23
       (VALUES (NREVERSE K) L))))
 
24
 
 
25
(DEFMACRO WITH-KEYWORD-PAIRS ((NAMES EXPRESSION &OPTIONAL KEYWORDS-VAR) &BODY FORMS)
 
26
  (LET ((TEMP (MEMBER '&REST NAMES)))
 
27
    (UNLESS (= (LENGTH TEMP) 2) (ERROR "&REST keyword is ~:[missing~;misplaced~]." TEMP))
 
28
    (LET ((KEY-VARS (LDIFF NAMES TEMP))
 
29
          (KEY-VAR (OR KEYWORDS-VAR (GENSYM)))
 
30
          (REST-VAR (CADR TEMP)))
 
31
      (LET ((KEYWORDS (MAPCAR #'(LAMBDA (X) (INTERN (STRING X) (FIND-PACKAGE "KEYWORD")))
 
32
                              KEY-VARS)))
 
33
        `(MULTIPLE-VALUE-BIND (,KEY-VAR ,REST-VAR)
 
34
             (PARSE-KEYWORD-PAIRS ,EXPRESSION ',KEYWORDS)
 
35
           (LET ,(MAPCAR #'(LAMBDA (VAR KEYWORD) `(,VAR (GETF ,KEY-VAR ,KEYWORD)))
 
36
                                 KEY-VARS KEYWORDS)
 
37
             ,@FORMS))))))
 
38
 
 
39
);NEHW-LAVE
 
40
 
 
41
;;; Restarts
 
42
 
 
43
(DEFVAR *RESTART-CLUSTERS* '())
 
44
 
 
45
(DEFUN COMPUTE-RESTARTS ()
 
46
  #+kcl (nconc (mapcan #'copy-list *RESTART-CLUSTERS*) (kcl-top-restarts))
 
47
  #-kcl (mapcan #'copy-list *RESTART-CLUSTERS*))
 
48
 
 
49
(DEFUN RESTART-PRINT (RESTART STREAM DEPTH)
 
50
  (DECLARE (IGNORE DEPTH))
 
51
  (IF *PRINT-ESCAPE*
 
52
      (FORMAT STREAM "#<~S.~D>" (TYPE-OF RESTART) (UNIQUE-ID RESTART))
 
53
      (RESTART-REPORT RESTART STREAM)))
 
54
 
 
55
(DEFSTRUCT (RESTART (:PRINT-FUNCTION RESTART-PRINT))
 
56
  NAME
 
57
  FUNCTION
 
58
  REPORT-FUNCTION
 
59
  INTERACTIVE-FUNCTION)
 
60
 
 
61
#+kcl
 
62
(progn
 
63
(defvar *kcl-top-restarts* nil)
 
64
 
 
65
(defun make-kcl-top-restart (quit-tag)
 
66
  (make-restart :name 'abort
 
67
                :function #'(lambda () (throw (car (list quit-tag)) quit-tag))
 
68
                :report-function 
 
69
                #'(lambda (stream) 
 
70
                    (let ((b-l (if (eq quit-tag si::*quit-tag*)
 
71
                                   si::*break-level*
 
72
                                   (car (or (find quit-tag si::*quit-tags*
 
73
                                                  :key #'cdr)
 
74
                                            '(:not-found))))))
 
75
                      (cond ((eq b-l :not-found)
 
76
                             (format stream "Return to ? level."))
 
77
                            ((null b-l)
 
78
                             (format stream "Return to top level."))
 
79
                            (t
 
80
                             (format stream "Return to break level ~D."
 
81
                                     (length b-l))))))
 
82
                :interactive-function nil))
 
83
 
 
84
(defun find-kcl-top-restart (quit-tag)
 
85
  (cdr (or (assoc quit-tag *kcl-top-restarts*)
 
86
           (car (push (cons quit-tag (make-kcl-top-restart quit-tag))
 
87
                      *kcl-top-restarts*)))))
 
88
 
 
89
(defun kcl-top-restarts ()
 
90
  (let* ((old-tags (mapcan #'(lambda (e) (when (cdr e) (list (cdr e))))
 
91
                           si::*quit-tags*))
 
92
         (tags (if si::*quit-tag* (cons si::*quit-tag* old-tags) old-tags))
 
93
         (restarts (mapcar #'find-kcl-top-restart tags)))
 
94
    (setq *kcl-top-restarts* (mapcar #'cons tags restarts))
 
95
    restarts))
 
96
)  
 
97
 
 
98
(DEFUN RESTART-REPORT (RESTART STREAM)
 
99
  (FUNCALL (OR (RESTART-REPORT-FUNCTION RESTART)
 
100
               (LET ((NAME (RESTART-NAME RESTART)))
 
101
                 #'(LAMBDA (STREAM)
 
102
                     (IF NAME (FORMAT STREAM "~S" NAME)
 
103
                              (FORMAT STREAM "~S" RESTART)))))
 
104
           STREAM))
 
105
 
 
106
(DEFMACRO RESTART-BIND (BINDINGS &BODY FORMS)
 
107
  `(LET ((*RESTART-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (BINDING)
 
108
                                                       `(MAKE-RESTART
 
109
                                                          :NAME     ',(CAR BINDING)
 
110
                                                          :FUNCTION ,(CADR BINDING)
 
111
                                                          ,@(CDDR BINDING)))
 
112
                                                   BINDINGS))
 
113
                                   *RESTART-CLUSTERS*)))
 
114
     ,@FORMS))
 
115
 
 
116
(DEFUN FIND-RESTART (NAME)
 
117
  (DOLIST (RESTART-CLUSTER *RESTART-CLUSTERS*)
 
118
    (DOLIST (RESTART RESTART-CLUSTER)
 
119
      (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))
 
120
        (RETURN-FROM FIND-RESTART RESTART))))
 
121
  #+kcl 
 
122
  (let ((RESTART-CLUSTER (kcl-top-restarts)))
 
123
    (DOLIST (RESTART RESTART-CLUSTER)
 
124
      (WHEN (OR (EQ RESTART NAME) (EQ (RESTART-NAME RESTART) NAME))
 
125
        (RETURN-FROM FIND-RESTART RESTART)))))
 
126
  
 
127
(DEFUN INVOKE-RESTART (RESTART &REST VALUES)
 
128
  (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)
 
129
                          (ERROR "Restart ~S is not active." RESTART))))
 
130
    (APPLY (RESTART-FUNCTION REAL-RESTART) VALUES)))
 
131
 
 
132
(DEFUN INVOKE-RESTART-INTERACTIVELY (RESTART)
 
133
  (LET ((REAL-RESTART (OR (FIND-RESTART RESTART)
 
134
                          (ERROR "Restart ~S is not active." RESTART))))
 
135
    (APPLY (RESTART-FUNCTION REAL-RESTART)
 
136
           (LET ((INTERACTIVE-FUNCTION
 
137
                   (RESTART-INTERACTIVE-FUNCTION REAL-RESTART)))
 
138
             (IF INTERACTIVE-FUNCTION
 
139
                 (FUNCALL INTERACTIVE-FUNCTION)
 
140
                 '())))))
 
141
 
 
142
(DEFMACRO RESTART-CASE (EXPRESSION &BODY CLAUSES)
 
143
  (FLET ((TRANSFORM-KEYWORDS (&KEY REPORT INTERACTIVE)
 
144
           (LET ((RESULT '()))
 
145
             (WHEN REPORT
 
146
               (SETQ RESULT (LIST* (IF (STRINGP REPORT)
 
147
                                       `#'(LAMBDA (STREAM)
 
148
                                            (WRITE-STRING ,REPORT STREAM))
 
149
                                       `#',REPORT)
 
150
                                   :REPORT-FUNCTION
 
151
                                   RESULT)))
 
152
             (WHEN INTERACTIVE
 
153
               (SETQ RESULT (LIST* `#',INTERACTIVE
 
154
                                   :INTERACTIVE-FUNCTION
 
155
                                   RESULT)))
 
156
             (NREVERSE RESULT))))
 
157
    (LET ((BLOCK-TAG (GENSYM))
 
158
          (TEMP-VAR  (GENSYM))
 
159
          (DATA
 
160
            (MAPCAR #'(LAMBDA (CLAUSE)
 
161
                        (WITH-KEYWORD-PAIRS ((REPORT INTERACTIVE &REST FORMS)
 
162
                                             (CDDR CLAUSE))
 
163
                          (LIST (CAR CLAUSE)                       ;Name=0
 
164
                                (GENSYM)                           ;Tag=1
 
165
                                (TRANSFORM-KEYWORDS :REPORT REPORT ;Keywords=2
 
166
                                                    :INTERACTIVE INTERACTIVE)
 
167
                                (CADR CLAUSE)                      ;BVL=3
 
168
                                FORMS)))                           ;Body=4
 
169
                    CLAUSES)))
 
170
      `(BLOCK ,BLOCK-TAG
 
171
         (LET ((,TEMP-VAR NIL))
 
172
           (TAGBODY
 
173
             (RESTART-BIND
 
174
               ,(MAPCAR #'(LAMBDA (DATUM)
 
175
                            (LET ((NAME (NTH 0 DATUM))
 
176
                                  (TAG  (NTH 1 DATUM))
 
177
                                  (KEYS (NTH 2 DATUM)))
 
178
                              `(,NAME #'(LAMBDA (&REST TEMP)
 
179
                                          #+LISPM (SETQ TEMP (COPY-LIST TEMP))
 
180
                                          (SETQ ,TEMP-VAR TEMP)
 
181
                                          (GO ,TAG))
 
182
                                ,@KEYS)))
 
183
                        DATA)
 
184
               (RETURN-FROM ,BLOCK-TAG ,EXPRESSION))
 
185
             ,@(MAPCAN #'(LAMBDA (DATUM)
 
186
                           (LET ((TAG  (NTH 1 DATUM))
 
187
                                 (BVL  (NTH 3 DATUM))
 
188
                                 (BODY (NTH 4 DATUM)))
 
189
                             (LIST TAG
 
190
                                   `(RETURN-FROM ,BLOCK-TAG
 
191
                                      (APPLY #'(LAMBDA ,BVL ,@BODY)
 
192
                                             ,TEMP-VAR)))))
 
193
                       DATA)))))))
 
194
 
 
195
(DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME FORMAT-STRING
 
196
                                             &REST FORMAT-ARGUMENTS)
 
197
                               &BODY FORMS)
 
198
  `(RESTART-CASE (PROGN ,@FORMS)
 
199
     (,RESTART-NAME ()
 
200
        :REPORT (LAMBDA (STREAM)
 
201
                  (FORMAT STREAM ,FORMAT-STRING ,@FORMAT-ARGUMENTS))
 
202
      (VALUES NIL T))))
 
203
 
 
204
(DEFUN ABORT          ()      (INVOKE-RESTART 'ABORT)
 
205
                              (ERROR 'ABORT-FAILURE))
 
206
(DEFUN CONTINUE       ()      (INVOKE-RESTART 'CONTINUE))
 
207
(DEFUN MUFFLE-WARNING ()      (INVOKE-RESTART 'MUFFLE-WARNING))
 
208
(DEFUN STORE-VALUE    (VALUE) (INVOKE-RESTART 'STORE-VALUE VALUE))
 
209
(DEFUN USE-VALUE      (VALUE) (INVOKE-RESTART 'USE-VALUE   VALUE))