← Back to branch summary

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

« back to all changes in this revision

Viewing changes to clcs/clcs_macros.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_macros.lisp
 
1
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
 
2
 
 
3
(IN-PACKAGE "CONDITIONS")
 
4
 
 
5
(EVAL-WHEN (EVAL COMPILE LOAD)
 
6
 
 
7
(DEFUN ACCUMULATE-CASES (MACRO-NAME CASES LIST-IS-ATOM-P)
 
8
  (DO ((L '())
 
9
       (C CASES (CDR C)))
 
10
      ((NULL C) (NREVERSE L))
 
11
      (LET ((KEYS (CAAR C)))
 
12
           (COND ((ATOM KEYS)
 
13
                  (COND ((NULL KEYS))
 
14
                        ((MEMBER KEYS '(OTHERWISE T))
 
15
                         (IF (NOT (MEMBER MACRO-NAME '( ECASE CCASE ETYPECASE CTYPECASE)))
 
16
                             (ERROR "OTHERWISE is not allowed in ~S expressions." MACRO-NAME))
 
17
                           (PUSH (LIST KEYS) L))
 
18
                        (T (PUSH KEYS L))))
 
19
                 (LIST-IS-ATOM-P
 
20
                  (PUSH KEYS L))
 
21
                 (T (DOLIST (KEY KEYS) (PUSH KEY L)))))))
 
22
);NEHW-LAVE
 
23
 
 
24
;(DEFUN ESCAPE-SPECIAL-CASES (CASES)
 
25
;  (DO ((L '())
 
26
;       (C CASES (CDR C)))
 
27
;      ((NULL C) (NREVERSE L))
 
28
;      (LET ((KEYS (CAAR C)))
 
29
;          (COND ((ATOM KEYS)
 
30
;                 (COND ((NULL KEYS))
 
31
;                       ((MEMBER KEYS '(OTHERWISE T))
 
32
;                         (PUSH (CONS (LIST KEYS) (CDR (CAR C))) L))
 
33
;                       (T (PUSH (CONS KEYS (CDR (CAR C))) L))))
 
34
;                (T
 
35
;                 (PUSH (CONS KEYS (CDR (CAR C))) L))))))
 
36
 
 
37
(DEFUN ESCAPE-SPECIAL-CASES-REPLACE (CASES)
 
38
  (DO ((C CASES (CDR C)))
 
39
      ((NULL C) CASES)
 
40
      (LET ((KEYS (CAAR C)))
 
41
           (IF (MEMBER KEYS '(OTHERWISE T))
 
42
               (RPLACA (CAR C) (LIST KEYS))))))
 
43
 
 
44
(DEFMACRO ECASE (KEYFORM &REST CASES)
 
45
  (LET ((KEYS (ACCUMULATE-CASES 'ECASE CASES NIL))
 
46
        (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES))
 
47
        (VAR (GENSYM)))
 
48
    `(LET ((,VAR ,KEYFORM))
 
49
       (CASE ,VAR
 
50
         ,@NCASES
 
51
         (OTHERWISE
 
52
           (ERROR 'CASE-FAILURE :NAME 'ECASE
 
53
                                :DATUM ,VAR
 
54
                                :EXPECTED-TYPE '(MEMBER ,@KEYS)
 
55
                                :POSSIBILITIES ',KEYS))))))
 
56
 
 
57
(DEFMACRO CCASE (KEYPLACE &REST CASES)
 
58
  (LET ((KEYS (ACCUMULATE-CASES 'CCASE CASES NIL))
 
59
        (NCASES (ESCAPE-SPECIAL-CASES-REPLACE CASES))
 
60
        (TAG1 (GENSYM))
 
61
        (TAG2 (GENSYM)))
 
62
    `(BLOCK ,TAG1
 
63
       (TAGBODY ,TAG2
 
64
         (RETURN-FROM ,TAG1
 
65
           (CASE ,KEYPLACE
 
66
             ,@NCASES
 
67
             (OTHERWISE
 
68
               (RESTART-CASE (ERROR 'CASE-FAILURE
 
69
                                    :NAME 'CCASE
 
70
                                    :DATUM ,KEYPLACE
 
71
                                    :EXPECTED-TYPE '(MEMBER ,@KEYS)
 
72
                                    :POSSIBILITIES ',KEYS)
 
73
                 (STORE-VALUE (VALUE)
 
74
                     :REPORT (LAMBDA (STREAM)
 
75
                               (FORMAT STREAM "Supply a new value of ~S."
 
76
                                       ',KEYPLACE))
 
77
                     :INTERACTIVE READ-EVALUATED-FORM
 
78
                   (SETF ,KEYPLACE VALUE)
 
79
                   (GO ,TAG2))))))))))
 
80
 
 
81
(DEFMACRO ETYPECASE (KEYFORM &REST CASES)
 
82
  (LET ((TYPES (ACCUMULATE-CASES 'ETYPECASE CASES T))
 
83
        (VAR (GENSYM)))
 
84
    `(LET ((,VAR ,KEYFORM))
 
85
       (TYPECASE ,VAR
 
86
         ,@CASES
 
87
         (OTHERWISE
 
88
           (ERROR 'CASE-FAILURE :NAME 'ETYPECASE
 
89
                                :DATUM ,VAR
 
90
                                :EXPECTED-TYPE '(OR ,@TYPES)
 
91
                                :POSSIBILITIES ',TYPES))))))
 
92
 
 
93
(DEFMACRO CTYPECASE (KEYPLACE &REST CASES)
 
94
  (LET ((TYPES (ACCUMULATE-CASES 'CTYPECASE CASES T))
 
95
        (TAG1 (GENSYM))
 
96
        (TAG2 (GENSYM)))
 
97
    `(BLOCK ,TAG1
 
98
       (TAGBODY ,TAG2
 
99
         (RETURN-FROM ,TAG1
 
100
           (TYPECASE ,KEYPLACE
 
101
             ,@CASES
 
102
             (OTHERWISE
 
103
               (RESTART-CASE (ERROR 'CASE-FAILURE
 
104
                                    :NAME 'CTYPECASE
 
105
                                    :DATUM ,KEYPLACE
 
106
                                    :EXPECTED-TYPE '(OR ,@TYPES)
 
107
                                    :POSSIBILITIES ',TYPES)
 
108
                 (STORE-VALUE (VALUE)
 
109
                     :REPORT (LAMBDA (STREAM)
 
110
                               (FORMAT STREAM "Supply a new value of ~S."
 
111
                                       ',KEYPLACE))
 
112
                     :INTERACTIVE READ-EVALUATED-FORM
 
113
                   (SETF ,KEYPLACE VALUE)
 
114
                   (GO ,TAG2))))))))))
 
115
 
 
116
(DEFUN ASSERT-REPORT (NAMES STREAM)
 
117
  (FORMAT STREAM "Retry assertion")
 
118
  (IF NAMES
 
119
      (FORMAT STREAM " with new value~P for ~{~S~^, ~}."
 
120
              (LENGTH NAMES) NAMES)
 
121
      (FORMAT STREAM ".")))
 
122
 
 
123
(DEFUN ASSERT-PROMPT (NAME VALUE)
 
124
  (COND ((Y-OR-N-P "The old value of ~S is ~S.~
 
125
                  ~%Do you want to supply a new value? "
 
126
                   NAME VALUE)
 
127
         (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")
 
128
         (FLET ((READ-IT () (EVAL (READ *QUERY-IO*))))
 
129
           (IF (SYMBOLP NAME) ;Help user debug lexical variables
 
130
               (PROGV (LIST NAME) (LIST VALUE) (READ-IT))
 
131
               (READ-IT))))
 
132
        (T VALUE)))
 
133
 
 
134
(DEFUN SIMPLE-ASSERTION-FAILURE (ASSERTION)
 
135
  (ERROR 'SIMPLE-TYPE-ERROR
 
136
         :DATUM ASSERTION
 
137
         :EXPECTED-TYPE NIL                     ; This needs some work in next revision. -kmp
 
138
         :FORMAT-STRING "The assertion ~S failed."
 
139
         :FORMAT-ARGUMENTS (LIST ASSERTION)))
 
140
 
 
141
(DEFMACRO ASSERT (TEST-FORM &OPTIONAL PLACES DATUM &REST ARGUMENTS)
 
142
  (LET ((TAG (GENSYM)))
 
143
    `(TAGBODY ,TAG
 
144
       (UNLESS ,TEST-FORM
 
145
         (RESTART-CASE ,(IF DATUM
 
146
                            `(ERROR ,DATUM ,@ARGUMENTS)
 
147
                            `(SIMPLE-ASSERTION-FAILURE ',TEST-FORM))
 
148
           (CONTINUE ()
 
149
               :REPORT (LAMBDA (STREAM) (ASSERT-REPORT ',PLACES STREAM))
 
150
             ,@(MAPCAR #'(LAMBDA (PLACE)
 
151
                           `(SETF ,PLACE (ASSERT-PROMPT ',PLACE ,PLACE)))
 
152
                       PLACES)
 
153
             (GO ,TAG)))))))
 
154
 
 
155
(DEFUN READ-EVALUATED-FORM ()
 
156
  (FORMAT *QUERY-IO* "~&Type a form to be evaluated:~%")
 
157
  (LIST (EVAL (READ *QUERY-IO*))))
 
158
 
 
159
(DEFMACRO CHECK-TYPE (PLACE TYPE &OPTIONAL TYPE-STRING)
 
160
  (LET ((TAG1 (GENSYM))
 
161
        (TAG2 (GENSYM)))
 
162
    `(BLOCK ,TAG1
 
163
       (TAGBODY ,TAG2
 
164
         (IF (TYPEP ,PLACE ',TYPE) (RETURN-FROM ,TAG1 NIL))
 
165
         (RESTART-CASE ,(IF TYPE-STRING
 
166
                            `(ERROR "The value of ~S is ~S, ~
 
167
                                     which is not ~A."
 
168
                                    ',PLACE ,PLACE ,TYPE-STRING)
 
169
                            `(ERROR "The value of ~S is ~S, ~
 
170
                                     which is not of type ~S."
 
171
                                    ',PLACE ,PLACE ',TYPE))
 
172
           (STORE-VALUE (VALUE)
 
173
               :REPORT (LAMBDA (STREAM)
 
174
                         (FORMAT STREAM "Supply a new value of ~S."
 
175
                                 ',PLACE))
 
176
               :INTERACTIVE READ-EVALUATED-FORM
 
177
             (SETF ,PLACE VALUE)
 
178
             (GO ,TAG2)))))))