68a9b5d6f4e753160743734641df1a6f3aad3717
[software/python-on-guile.git] / modules / language / python / try.scm
1 (define-module (language python try)
2 #:use-module (language python exceptions)
3 #:use-module (language python yield)
4 #:use-module (oop pf-objects)
5 #:use-module (oop goops)
6 #:use-module (ice-9 control)
7 #:use-module (ice-9 match)
8 #:replace (raise)
9 #:export (try))
10
11 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
12
13 (define-inlinable (standard-check class obj l)
14 (cond
15 ((eq? class #t)
16 #t)
17 ((struct? obj)
18 (if (is-a? obj <p>)
19 (if (is-a? class <p>)
20 (is-a? obj (ref class '__goops__))
21 (is-a? obj class))
22 (if (is-a? obj <object>)
23 (is-a? obj class)
24 (eq? obj class))))
25 ((and (procedure? class) (not (pyclass? class)))
26 (apply class obj l))
27 (else
28 (eq? class obj))))
29
30
31 (define (check class obj l)
32 (standard-check class obj l))
33
34 (define-syntax compile-error
35 (lambda (x)
36 (syntax-case x ()
37 ((_ x)
38 (error (syntax->datum #'x))))))
39
40 (define-syntax check-exception
41 (syntax-rules (and or not)
42 ((_ (or E ...) tag l)
43 (or (check-exception E tag l) ...))
44 ((_ (and E ...) tag l)
45 (and (check-exception E tag l) ...))
46 ((_ (not E) tag l)
47 (not (check-exception E tag l)))
48 ((_ E tag l)
49 (check E tag l))))
50
51 (define (m code)
52 (let ((c code))
53 (lambda (k . l)
54 (if (eq? k StopIteration)
55 (apply c 'python k l)
56 (apply c k l)))))
57
58 (define-syntax handler
59 (syntax-rules (=>)
60 ((handler ecx)
61 (m
62 (lambda (k tag . l)
63 (handler ecx tag l))))
64
65 ((handler ((#:except E => lam) . ecx) tag l)
66 (if (check-exception E tag l)
67 (lam tag l)
68 (handler ecx tag l)))
69
70 ((handler ((#:except E) . ecx) tag l)
71 (if (check-exception E tag l)
72 (begin (values))
73 (handler ecx tag l)))
74
75 ((handler ((#:except E code ...) . ecx) tag l)
76 (if (check-exception E tag l)
77 (begin code ...)
78 (handler ecx tag l)))
79
80 ((handler ((#:else code ...)) tag l)
81 (begin code ...))
82
83 ((handler () tag l)
84 (apply throw 'python tag l))
85
86 ((a ...)
87 (compile-error "not a proper python macro try block"))))
88
89
90
91 (define-syntax try
92 (syntax-rules ()
93 ((try code exc ... #:finally fin)
94 (dynamic-wind
95 (lambda () #f)
96 (lambda ()
97 (catch #t
98 code
99 (handler (exc ...))))
100 (lambda ()
101 (if (not (fluid-ref in-yield))
102 (fin)))))
103
104 ((try code exc ...)
105 (catch #t
106 code
107 (handler (exc ...))))))
108
109
110 (define raise
111 (case-lambda
112 ((x . l)
113 (if (pyclass? x)
114 (throw 'python (apply x l))
115 (apply throw 'python x l)))
116
117 (() (raise Exception))))