1 ; Scheme program to produce CORBA standard exceptions class |
|
2 ; requires Jscheme Java extensions |
|
3 ; Makes use of some custom Java classes also |
|
4 |
|
5 (import "com.sun.tools.corba.se.logutil.IndentingPrintWriter" ) |
|
6 (import "com.sun.tools.corba.se.logutil.StringUtil" ) |
|
7 (import "java.io.FileOutputStream") |
|
8 |
|
9 (define version-string "1.3") |
|
10 |
|
11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
12 ;; Utility functions |
|
13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
14 |
|
15 ; reload this file (convenience definition) |
|
16 (define (reload) (load "mc.scm")) |
|
17 |
|
18 ; Simple little function to report an error |
|
19 (define (error msg) |
|
20 (throw (Error. msg))) |
|
21 |
|
22 ; some debug support |
|
23 (define debug #f) |
|
24 |
|
25 (define (dprint msg) |
|
26 (if debug |
|
27 (.println System.out$ msg))) |
|
28 |
|
29 ; Replace dprint with noprint to avoid seeing messages when debug is #t |
|
30 (define (noprint msg) ()) |
|
31 |
|
32 ; Helper function present so that a scheme method taking strings as args |
|
33 ; can be easily run from a command line. |
|
34 ; arg: vector containing argument strings. Element 0 is the function name |
|
35 ; to execute |
|
36 (define (main arg) |
|
37 (let* |
|
38 ( |
|
39 (arg-list (vector->list arg)) |
|
40 (function-symbol (string->symbol (car arg-list))) |
|
41 (args (cdr arg-list))) |
|
42 (apply (eval function-symbol) args))) |
|
43 |
|
44 ; Returns the position of key in lst, numbering from 0. key is matched using eqv? |
|
45 (define (get-list-position key lst) |
|
46 (letrec |
|
47 ( |
|
48 (helper (lambda (k l accum) |
|
49 (cond |
|
50 ((null? l) (error (string-append "Could not find " k))) |
|
51 ((eqv? k (car l)) accum) |
|
52 (else (helper k (cdr l) (+ accum 1))) )))) |
|
53 (begin |
|
54 (noprint (string-append "get-list-position called with key " key " lst " lst )) |
|
55 (helper key lst 0)))) |
|
56 |
|
57 ; Return a string representing number in decimal padded to length with leading 0s. |
|
58 (define (pad-number-string number length) |
|
59 (let* |
|
60 ( |
|
61 (number-string (number->string number)) |
|
62 (pad-length (- length (string-length number-string))) |
|
63 ) |
|
64 (string-append (make-string pad-length #\0) number-string))) |
|
65 |
|
66 ; Read an S-expression from a file that contains all of the data. |
|
67 ; |
|
68 ; The S-expression used for minor codes must have the structure |
|
69 ; (package-name class-name exception-group-name |
|
70 ; (exception |
|
71 ; (name value level explanation) |
|
72 ; ... |
|
73 ; ) |
|
74 ; ... |
|
75 ; ) |
|
76 (define (read-file fname) |
|
77 (read (open-input-file fname))) |
|
78 |
|
79 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
80 ;; Functions for handling major system exceptions and exception groups |
|
81 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
82 |
|
83 ; Function to find the base ID given an exception group name. Result is a function that |
|
84 ; maps the minor code into the Java expression for that minor code's actual value. |
|
85 (define (get-base group-name) |
|
86 (if (eqv? group-name 'OMG) |
|
87 (lambda (minor-code) |
|
88 (string-append "OMGVMCID.value + " (number->string minor-code))) |
|
89 (let ; bind base-number outside the lambda so it is only evaluated once |
|
90 ( |
|
91 (base-number (get-sun-base-number group-name))) |
|
92 (lambda (minor-code) |
|
93 (string-append "SUNVMCID.value + " (number->string (+ base-number minor-code))))))) |
|
94 |
|
95 ; Function to get a base value for the group-name |
|
96 (define (get-sun-base-number group-name) |
|
97 (let* |
|
98 ( |
|
99 (lst (list 'SUNBASE 'ORBUTIL 'ACTIVATION 'NAMING 'INTERCEPTORS 'POA 'IOR 'UTIL)) |
|
100 (subsystem-size 200)) |
|
101 (* subsystem-size (get-list-position group-name lst)))) |
|
102 |
|
103 ; Function to get a 3 digit number for a system exception |
|
104 (define (get-exception-id exception-name) |
|
105 (let |
|
106 ( |
|
107 (lst (list 'UNKNOWN 'BAD_PARAM 'NO_MEMORY 'IMP_LIMIT 'COMM_FAILURE 'INV_OBJREF 'NO_PERMISSION |
|
108 'INTERNAL 'MARSHAL 'INITIALIZE 'NO_IMPLEMENT 'BAD_TYPECODE 'BAD_OPERATION 'NO_RESOURCES |
|
109 'NO_RESPONSE 'PERSIST_STORE 'BAD_INV_ORDER 'TRANSIENT 'FREE_MEM 'INV_IDENT 'INV_FLAG |
|
110 'INTF_REPOS 'BAD_CONTEXT 'OBJ_ADAPTER 'DATA_CONVERSION 'OBJECT_NOT_EXIST 'TRANSACTION_REQUIRED |
|
111 'TRANSACTION_ROLLEDBACK 'INVALID_TRANSACTION 'INV_POLICY 'CODESET_INCOMPATIBLE 'REBIND |
|
112 'TIMEOUT 'TRANSACTION_UNAVAILABLE 'BAD_QOS 'INVALID_ACTIVITY 'ACTIVITY_COMPLETED |
|
113 'ACTIVITY_REQUIRED ))) |
|
114 (pad-number-string (get-list-position exception-name lst) 3))) |
|
115 |
|
116 ; Return the message id string for any system exception |
|
117 ; |
|
118 (define (get-message-id exception-type group-name minor) |
|
119 (if (eqv? group-name 'OMG) |
|
120 (get-standard-message-id exception-type minor) |
|
121 (get-sun-message-id exception-type group-name minor))) |
|
122 |
|
123 ; Return the message id string for a particular standard exception |
|
124 ; |
|
125 (define (get-standard-message-id exception-type minor) |
|
126 (string-append |
|
127 "IOP" |
|
128 (get-exception-id exception-type) |
|
129 "0" |
|
130 (pad-number-string (number->string minor) 4))) |
|
131 |
|
132 ; Return the sun message id for this exception-type, group-name, and minor code. |
|
133 (define (get-sun-message-id exception-type group-name minor) |
|
134 (string-append |
|
135 "IOP" |
|
136 (get-exception-id exception-type) |
|
137 "1" |
|
138 (pad-number-string (+ (get-sun-base-number group-name) minor) 4))) |
|
139 |
|
140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
141 ; visitor framework for the input file format |
|
142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
143 |
|
144 (define (visit-top obj func1) |
|
145 (let* |
|
146 ( |
|
147 (package (car obj)) |
|
148 (class (cadr obj)) |
|
149 (group (caddr obj)) |
|
150 (func2 (func1 package class group)) |
|
151 (exceptions (cadddr obj))) |
|
152 (visit-exceptions exceptions func2))) |
|
153 |
|
154 ; visit the elements of an arbitrary list |
|
155 ; lst: the list to visit |
|
156 ; func: the function to apply to each element of lst |
|
157 ; next-level the function on lst element and func that visits the next level |
|
158 (define (visit-list lst func next-level) |
|
159 (if (null? (cdr lst)) |
|
160 (next-level #t (car lst) func) |
|
161 (begin |
|
162 (next-level #f (car lst) func) |
|
163 (visit-list (cdr lst) func next-level)))) |
|
164 |
|
165 (define (visit-exceptions exceptions func2) |
|
166 (visit-list exceptions func2 (lambda (last-flag element func) (visit-exception last-flag element func)))) |
|
167 |
|
168 (define (visit-exception last-flag exception func2) |
|
169 (let* |
|
170 ( |
|
171 (major (car exception)) |
|
172 (minor-codes (cdr exception)) |
|
173 (func3 (func2 last-flag major))) |
|
174 (visit-minor-codes minor-codes func3))) |
|
175 |
|
176 (define (visit-minor-codes minor-codes func3) |
|
177 (visit-list minor-codes func3 (lambda (last-flag element func) (visit-minor-code last-flag element func)))) |
|
178 |
|
179 (define (visit-minor-code last-flag minor-code func3) |
|
180 (let* |
|
181 ( |
|
182 (name (car minor-code)) |
|
183 (minor (cadr minor-code)) |
|
184 (level (caddr minor-code)) |
|
185 (msg (cadddr minor-code))) |
|
186 (func3 last-flag name minor level msg))) |
|
187 |
|
188 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
189 ;; The visitors |
|
190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
191 |
|
192 ; A simple visitor that just echoes the input for test purposes |
|
193 (define (simple-visitor package class group) |
|
194 (let* |
|
195 ( |
|
196 (pw (IndentingPrintWriter. System.out$))) |
|
197 (begin |
|
198 (.indent pw) |
|
199 (.printMsg pw "package=@ class=@ group=@" (list package class group)) |
|
200 (.flush pw) |
|
201 (lambda (last-flag major) |
|
202 (begin |
|
203 (.indent pw) |
|
204 (.printMsg pw "major=@" (list major)) |
|
205 (.flush pw) |
|
206 (lambda (last-flag name minor level message) |
|
207 (begin |
|
208 (if last-flag (.undent pw)) |
|
209 (.printMsg pw "name=@ minor=@ level=@ message=@" (list name minor level message)) |
|
210 (.flush pw)))))))) |
|
211 |
|
212 ; Function that returns a visitor that writes out the resource file in the form: |
|
213 ; id="MSGID: explanation" |
|
214 ; outdir: Output directory |
|
215 (define (resource-visitor outdir) |
|
216 (lambda (package class group) |
|
217 (let* |
|
218 ( |
|
219 (file-name (string-append outdir java.io.File.separator$ class ".resource")) |
|
220 (pw (IndentingPrintWriter. (FileOutputStream. file-name)))) |
|
221 (begin |
|
222 (dprint (string-append "package= " package " class=" class " group=" group " file-name=" file-name)) |
|
223 (lambda (last-flag1 major) |
|
224 (begin |
|
225 ; (dprint (string-append "last-flag1=" last-flag1 " major=" major)) |
|
226 (lambda (last-flag2 name minor level message) |
|
227 (begin |
|
228 ; (dprint (string-append "last-flag2=" last-flag2 " name=" name |
|
229 ; " minor=" minor " level=" level " message=" message)) |
|
230 (let* |
|
231 ( |
|
232 (msgid (get-message-id major group minor)) |
|
233 (ident (StringUtil.toMixedCase (symbol->string name)))) |
|
234 (begin |
|
235 ; (dprint (string-append "msgid=" msgid " ident=" ident)) |
|
236 (.printMsg pw "@.@=\"@: (@) @\"" (list group ident msgid major message)) |
|
237 (.flush pw) |
|
238 (if (and last-flag1 last-flag2) |
|
239 (begin |
|
240 ; (dprint "closing file") |
|
241 (.close pw))))))))))))) |
|
242 |
|
243 |
|
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
245 ;; Top-level functions for creating the products. All have names of the form make-xxx |
|
246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
247 |
|
248 ; Read the minor codes from the infile and write out a resource file. |
|
249 (define (make-resource infile outdir) |
|
250 (tryCatch |
|
251 (visit-top (read-file infile) (resource-visitor outdir)) |
|
252 (lambda (exc) |
|
253 (begin |
|
254 (.println System.out$ (string-append "make-resource failed with exception " (.toString exc))) |
|
255 (System.exit 1))))) |
|
256 |
|
257 ; Read the minor codes from the infile and write a Java implementation to |
|
258 ; handle them to outfile under outdir |
|
259 (define (make-class infile outdir) |
|
260 (tryCatch |
|
261 (write-class infile outdir (read-file infile)) |
|
262 (lambda (exc) |
|
263 (begin |
|
264 (.println System.out$ (string-append "make-class failed with exception " (.toString exc))) |
|
265 (System.exit 1))))) |
|
266 |
|
267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
268 ;; The original make-class implementation (this should be replaced by two visitors) |
|
269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
270 |
|
271 ; Write out the Java source code for the StandardExceptions class |
|
272 ; outdir: Output directory to write the generated files |
|
273 ; obj: the data from the input file |
|
274 (define (write-class infile outdir obj) |
|
275 (let* |
|
276 ( |
|
277 (package-name (car obj)) |
|
278 (class-name (cadr obj)) |
|
279 (exception-group-name (caddr obj)) |
|
280 (exceptions (cadddr obj)) |
|
281 (file (FileOutputStream. (string-append outdir java.io.File.separator$ class-name ".java"))) |
|
282 (pw (IndentingPrintWriter. file)) |
|
283 ) |
|
284 (begin |
|
285 (write-class-header infile package-name class-name exception-group-name pw) |
|
286 (.printMsg pw "package @ ;" |
|
287 (list package-name)) |
|
288 (.println pw) |
|
289 (.println pw "import java.util.logging.Logger ;") |
|
290 (.println pw "import java.util.logging.Level ;") |
|
291 (.println pw) |
|
292 (.println pw "import org.omg.CORBA.OMGVMCID ;") |
|
293 (.println pw "import com.sun.corba.se.impl.util.SUNVMCID ;") |
|
294 (.println pw "import org.omg.CORBA.CompletionStatus ;") |
|
295 (.println pw "import org.omg.CORBA.SystemException ;") |
|
296 (.println pw) |
|
297 (.println pw "import com.sun.corba.se.spi.orb.ORB ;") |
|
298 (.println pw) |
|
299 (.println pw "import com.sun.corba.se.spi.logging.LogWrapperFactory;") |
|
300 (.println pw) |
|
301 (.println pw "import com.sun.corba.se.spi.logging.LogWrapperBase;") |
|
302 (.println pw) |
|
303 (write-imports exceptions pw) |
|
304 (.println pw) |
|
305 (.indent pw) |
|
306 (.printMsg pw "public class @ extends LogWrapperBase {" |
|
307 (list class-name)) |
|
308 (.println pw) |
|
309 (.printMsg pw "public @( Logger logger )" |
|
310 (list class-name)) |
|
311 (.indent pw) |
|
312 (.println pw "{") |
|
313 (.undent pw) |
|
314 (.println pw "super( logger ) ;") |
|
315 (.println pw "}") |
|
316 (.println pw) |
|
317 (.flush pw) |
|
318 (write-factory-method class-name exception-group-name pw) |
|
319 (write-exceptions exception-group-name exceptions (get-base exception-group-name) class-name pw) |
|
320 (.undent pw) |
|
321 (.println pw ) |
|
322 (.println pw "}") |
|
323 (.flush pw) |
|
324 (.close pw) |
|
325 ))) |
|
326 |
|
327 ; Write out the header for the resource file |
|
328 (define (write-class-header infile package class group pw) |
|
329 (begin |
|
330 (if (eqv? group 'OMG) |
|
331 (.println pw "// Log wrapper class for standard exceptions") |
|
332 (.printMsg pw "// Log wrapper class for Sun private system exceptions in group @" (list group))) |
|
333 (.println pw "//") |
|
334 (.printMsg pw "// Generated by mc.scm version @, DO NOT EDIT BY HAND!" (list version-string)) |
|
335 (.printMsg pw "// Generated from input file @ on @" (list infile (java.util.Date.))) |
|
336 (.println pw))) |
|
337 |
|
338 (define (write-factory-method class-name exception-group-name pw) |
|
339 (begin |
|
340 (.indent pw) |
|
341 (.println pw "private static LogWrapperFactory factory = new LogWrapperFactory() {") |
|
342 (.println pw "public LogWrapperBase create( Logger logger )" ) |
|
343 (.indent pw) |
|
344 (.println pw "{") |
|
345 (.undent pw) |
|
346 (.printMsg pw "return new @( logger ) ;" (list class-name)) |
|
347 (.undent pw) |
|
348 (.println pw "}" ) |
|
349 (.println pw "} ;" ) |
|
350 (.println pw) |
|
351 (.printMsg pw "public static @ get( ORB orb, String logDomain )" (list class-name)) |
|
352 (.indent pw) |
|
353 (.println pw "{") |
|
354 (.indent pw) |
|
355 (.printMsg pw "@ wrapper = " |
|
356 (list class-name)) |
|
357 (.indent pw) |
|
358 (.printMsg pw "(@) orb.getLogWrapper( logDomain, " |
|
359 (list class-name)) |
|
360 (.undent pw) |
|
361 (.undent pw) |
|
362 (.printMsg pw "\"@\", factory ) ;" |
|
363 (list exception-group-name)) |
|
364 (.undent pw) |
|
365 (.println pw "return wrapper ;" ) |
|
366 (.println pw "} " ) |
|
367 (.println pw) |
|
368 (.printMsg pw "public static @ get( String logDomain )" (list class-name)) |
|
369 (.indent pw) |
|
370 (.println pw "{") |
|
371 (.indent pw) |
|
372 (.printMsg pw "@ wrapper = " |
|
373 (list class-name)) |
|
374 (.indent pw) |
|
375 (.printMsg pw "(@) ORB.staticGetLogWrapper( logDomain, " |
|
376 (list class-name)) |
|
377 (.undent pw) |
|
378 (.undent pw) |
|
379 (.printMsg pw "\"@\", factory ) ;" |
|
380 (list exception-group-name)) |
|
381 (.undent pw) |
|
382 (.println pw "return wrapper ;" ) |
|
383 (.println pw "} " ) |
|
384 (.println pw))) |
|
385 |
|
386 ; Write out the import list for the exceptions listed in obj |
|
387 ; obj: the data from the input file |
|
388 ; pw: an IndentingPrintWriter for the output file |
|
389 (define (write-imports obj pw) |
|
390 (if (null? obj) |
|
391 () |
|
392 (let |
|
393 ( |
|
394 (exception (caar obj)) |
|
395 ) |
|
396 (begin |
|
397 (.print pw "import org.omg.CORBA.") |
|
398 (.print pw exception) |
|
399 (.println pw " ;") |
|
400 (write-imports (cdr obj) pw) |
|
401 )))) |
|
402 |
|
403 ; Write out the list of exceptions starting with the first one |
|
404 ; obj: the data from the input file |
|
405 ; base: the lambda that returns the string defining the minor code value |
|
406 ; pw: an IndentingPrintWriter for the output file |
|
407 (define (write-exceptions group-name obj base class-name pw) |
|
408 (if (null? obj) |
|
409 () |
|
410 (let* |
|
411 ( |
|
412 (record (car obj)) |
|
413 (exception (car record)) |
|
414 (minor-codes (cdr record)) |
|
415 ) |
|
416 (begin |
|
417 (write-exception group-name exception minor-codes base class-name pw) |
|
418 (write-exceptions group-name (cdr obj) base class-name pw) |
|
419 )))) |
|
420 |
|
421 ; Write out a single exception |
|
422 ; exception: the CORBA SystemException type |
|
423 ; base: the base for the minor code value |
|
424 ; minor-codes: a list of minor code data for each minor exception type |
|
425 ; pw: an IndentingPrintWriter for the output file |
|
426 (define (write-exception group-name exception minor-codes base class-name pw) |
|
427 (begin |
|
428 (.println pw "///////////////////////////////////////////////////////////") |
|
429 (.printMsg pw "// @" (list exception)) |
|
430 (.println pw "///////////////////////////////////////////////////////////") |
|
431 (.println pw) |
|
432 (write-methods group-name exception minor-codes base class-name pw) |
|
433 (.flush pw))) |
|
434 |
|
435 ; Write all of the methods for a single exception |
|
436 ; exception: the CORBA SystemException type |
|
437 ; base: the base for the minor code value |
|
438 ; minor-codes: a list of minor code data for each minor exception type |
|
439 ; pw: an IndentingPrintWriter for the output file |
|
440 (define (write-methods group-name exception minor-codes base class-name pw) |
|
441 (if (null? minor-codes) |
|
442 () |
|
443 (begin |
|
444 (write-method group-name exception (car minor-codes) base class-name pw) |
|
445 (write-methods group-name exception (cdr minor-codes) base class-name pw) |
|
446 ))) |
|
447 |
|
448 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
449 ;; Code that writes out the Java methods for exception handling |
|
450 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
451 |
|
452 ; Write the methods for a single minor code within an exception |
|
453 ; exception: the CORBA SystemException type |
|
454 ; minor-code: minor code data for one minor exception type |
|
455 ; (name value level explanation) |
|
456 ; base: the base for the minor code value |
|
457 ; pw: an IndentingPrintWriter for the output file |
|
458 (define (write-method group-name exception minor-code base class-name pw) |
|
459 (let* |
|
460 ( |
|
461 (x (symbol->string (car minor-code))) |
|
462 (ident (cons x (StringUtil.toMixedCase x))) |
|
463 (value (cadr minor-code)) |
|
464 (level (symbol->string (caddr minor-code))) |
|
465 (explanation (cadddr minor-code)) |
|
466 (num-params (StringUtil.countArgs explanation))) |
|
467 (begin |
|
468 (.printMsg pw "public static final int @ = @ ;" |
|
469 (list x (base value))) |
|
470 (.println pw ) |
|
471 (.flush pw ) |
|
472 (write-method-status-cause group-name exception ident level num-params class-name pw) |
|
473 (.println pw) |
|
474 (.flush pw) |
|
475 (write-method-status exception ident level num-params pw) |
|
476 (.println pw) |
|
477 (.flush pw) |
|
478 (write-method-cause exception ident level num-params pw) |
|
479 (.println pw) |
|
480 (.flush pw) |
|
481 (write-method-no-args exception ident level num-params pw) |
|
482 (.println pw) |
|
483 (.flush pw)))) |
|
484 |
|
485 ; Construct a string of the form arg1, ..., argn where n is num-params |
|
486 (define (make-arg-string fixed leading-comma-flag num-args) |
|
487 (let |
|
488 ( |
|
489 (helper (lambda (lcf n) |
|
490 (let* |
|
491 ( |
|
492 (numstr (number->string (- n 1)))) |
|
493 (if (or lcf (> n 1)) |
|
494 (string-append ", " fixed numstr) |
|
495 (string-append " " fixed numstr)))))) |
|
496 (cond |
|
497 ((eqv? num-args 0) " ") |
|
498 ((eqv? num-args 1) (helper leading-comma-flag 1)) |
|
499 (else (string-append |
|
500 (make-arg-string fixed leading-comma-flag (- num-args 1)) |
|
501 (helper leading-comma-flag num-args )))))) |
|
502 |
|
503 (define (make-decl-args leading-comma-flag num-args) |
|
504 (make-arg-string "Object arg" leading-comma-flag num-args)) |
|
505 |
|
506 (define (make-call-args leading-comma-flag num-args) |
|
507 (make-arg-string "arg" leading-comma-flag num-args)) |
|
508 |
|
509 ; make-xxx-args patterns: |
|
510 ; leading-comma-flag #t |
|
511 ; |
|
512 ; 0 " " |
|
513 ; 1 ", arg0" |
|
514 ; 2 ", arg0, arg1" |
|
515 ; 3 ", arg0, arg1, arg2" |
|
516 ; |
|
517 ; 0 " " |
|
518 ; 1 ", Object arg0" |
|
519 ; 2 ", Object arg0, Object arg1" |
|
520 ; 3 ", Object arg0, Object arg1, Object arg2" |
|
521 ; |
|
522 ; leading-comma-flag #f |
|
523 ; |
|
524 ; 0 " " |
|
525 ; 1 " arg0" |
|
526 ; 2 " arg0, arg1" |
|
527 ; 3 " arg0, arg1, arg2" |
|
528 ; |
|
529 ; 0 " " |
|
530 ; 1 " Object arg0" |
|
531 ; 2 " Object arg0, Object arg1" |
|
532 ; 3 " Object arg0, Object arg1, Object arg2" |
|
533 |
|
534 (define (emit-assignments num pw) |
|
535 (let |
|
536 ( |
|
537 (helper |
|
538 (lambda (n) |
|
539 (.printMsg pw "parameters[@] = arg@ ;" (list n n))))) |
|
540 (if (= num 1) |
|
541 (helper (- num 1)) |
|
542 (begin |
|
543 (emit-assignments (- num 1) pw) |
|
544 (helper (- num 1)))))) |
|
545 |
|
546 ; Write a method for an exception that takes a CompletionStatus and a cause |
|
547 ; exception: the CORBA system exception type |
|
548 ; id: the identifier for this exception in the form ( ident . mixed-case-ident ) |
|
549 ; level: the logging level |
|
550 ; num-params: number of parameters in the explanation string, which determines |
|
551 ; how many argn parameters we need |
|
552 ; pw: the indenting print writer we are using |
|
553 (define (write-method-status-cause group-name exception id level num-params class-name pw) |
|
554 (let* |
|
555 ( |
|
556 (ident (car id)) |
|
557 (ident-mc (cdr id))) |
|
558 (begin |
|
559 (.indent pw) |
|
560 (.printMsg pw "public @ @( CompletionStatus cs, Throwable t@) {" |
|
561 (list exception ident-mc (make-decl-args #t num-params))) |
|
562 (.printMsg pw "@ exc = new @( @, cs ) ;" |
|
563 (list exception exception ident )) |
|
564 |
|
565 (.indent pw) |
|
566 (.println pw "if (t != null)" ) |
|
567 (.undent pw) |
|
568 (.println pw "exc.initCause( t ) ;" ) |
|
569 (.println pw) |
|
570 |
|
571 (.indent pw) |
|
572 (.printMsg pw "if (logger.isLoggable( Level.@ )) {" |
|
573 (list level)) |
|
574 |
|
575 (if (> num-params 0) |
|
576 (begin |
|
577 (.printMsg pw "Object[] parameters = new Object[@] ;" |
|
578 (list (number->string num-params))) |
|
579 (emit-assignments num-params pw) |
|
580 ) |
|
581 (begin |
|
582 (.println pw "Object[] parameters = null ;" |
|
583 ))) |
|
584 |
|
585 (.indent pw) |
|
586 (.printMsg pw "doLog( Level.@, \"@.@\"," (list level group-name ident-mc)) |
|
587 (.undent pw) |
|
588 (.undent pw) |
|
589 (.printMsg pw "parameters, @.class, exc ) ;" (list class-name)) |
|
590 (.println pw "}") |
|
591 (.println pw) |
|
592 |
|
593 (.undent pw) |
|
594 (.println pw "return exc ;") |
|
595 |
|
596 (.println pw "}")))) |
|
597 |
|
598 ; Write a method for an exception that takes a CompletionStatus. The cause is null. |
|
599 ; |
|
600 ; exception: the CORBA system exception type |
|
601 ; id: the identifier for this exception in the form ( ident . mixed-case-ident ) |
|
602 ; level: the logging level |
|
603 ; num-params: number of parameters in the explanation string, which determines |
|
604 ; how many argn parameters we need |
|
605 ; pw: the indenting print writer we are using |
|
606 (define (write-method-status exception id level num-params pw) |
|
607 (let* |
|
608 ( |
|
609 (ident-mc (cdr id))) |
|
610 (begin |
|
611 (.indent pw) |
|
612 (.printMsg pw "public @ @( CompletionStatus cs@) {" |
|
613 (list exception ident-mc (make-decl-args #t num-params))) |
|
614 (.undent pw) |
|
615 (.printMsg pw "return @( cs, null@ ) ;" |
|
616 (list ident-mc (make-call-args #t num-params))) |
|
617 (.println pw "}")))) |
|
618 |
|
619 ; Write a method for an exception that takes a cause. The status is COMPLETED_NO. |
|
620 ; |
|
621 ; exception: the CORBA system exception type |
|
622 ; id: the identifier for this exception in the form ( ident . mixed-case-ident ) |
|
623 ; level: the logging level |
|
624 ; num-params: number of parameters in the explanation string, which determines |
|
625 ; how many argn parameters we need |
|
626 ; pw: the indenting print writer we are using |
|
627 (define (write-method-cause exception id level num-params pw) |
|
628 (let* |
|
629 ( |
|
630 (ident-mc (cdr id))) |
|
631 (begin |
|
632 (.indent pw) |
|
633 (.printMsg pw "public @ @( Throwable t@) {" |
|
634 (list exception ident-mc (make-decl-args #t num-params))) |
|
635 (.undent pw) |
|
636 (.printMsg pw "return @( CompletionStatus.COMPLETED_NO, t@ ) ;" |
|
637 (list ident-mc (make-call-args #t num-params))) |
|
638 (.println pw "}")))) |
|
639 |
|
640 ; Write a method for an exception that takes no arguments. This is COMPLETED_NO and |
|
641 ; a null cause. |
|
642 ; |
|
643 ; exception: the CORBA system exception type |
|
644 ; id: the identifier for this exception in the form ( ident . mixed-case-ident ) |
|
645 ; level: the logging level |
|
646 ; num-params: number of parameters in the explanation string, which determines |
|
647 ; how many argn parameters we need |
|
648 ; pw: the indenting print writer we are using |
|
649 (define (write-method-no-args exception id level num-params pw) |
|
650 (let* |
|
651 ( |
|
652 (ident-mc (cdr id))) |
|
653 (begin |
|
654 (.indent pw) |
|
655 (.printMsg pw "public @ @( @) {" |
|
656 (list exception ident-mc (make-decl-args #f num-params))) |
|
657 (.undent pw) |
|
658 (.printMsg pw "return @( CompletionStatus.COMPLETED_NO, null@ ) ;" |
|
659 (list ident-mc (make-call-args #t num-params))) |
|
660 (.println pw "}")))) |
|
661 |
|
662 ;;; end of file |
|