blob: 4467a78c362e6c09aa625c3aeae659156656c23f (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
(define-module (language python try)
#:use-module (language python exceptions)
#:use-module (language python yield)
#:use-module (oop pf-objects)
#:use-module (oop goops)
#:use-module (ice-9 control)
#:use-module (ice-9 match)
#:export (raise try))
(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
(define-method (check (class <class> ) obj l) (is-a? obj class))
(define-method (check (s <symbol>) obj l) (eq? obj s))
(define-method (check (p <procedure>) obj l)
(aif it (procedure-property p 'pyclass)
(is-a? obj it)
(p obj l)))
(define-syntax compile-error
(lambda (x)
(syntax-case x ()
((_ x)
(error (syntax->datum #'x))))))
(define-syntax check-exception
(syntax-rules (and or not)
((_ (or E ...) tag l)
(or (check-exception E tag l) ...))
((_ (and E ...) tag l)
(and (check-exception E tag l) ...))
((_ (not E) tag l)
(not (check-exception E tag l)))
((_ E tag l)
(check E tag l))))
(define-syntax handler
(syntax-rules (=>)
((handler ecx)
(lambda x
(match x
((_ 'python tag . l)
(handler ecx tag l))
((k . x)
(apply throw x)))))
((handler ((#:except E => lam) . ecx) tag l)
(if (check-exception E tag l)
(lam tag l)
(handler ecx tag l)))
((handler ((#:except E code ...) . ecx) tag l)
(if (check-exception E tag l)
(begin code ...)
(handler ecx tag l)))
((handler ((#:else code ...)) tag l)
(begin code ...))
((handler () tag l)
(apply throw 'python tag l))
((a ...)
(compile-error "not a proper python macro try block"))))
(define-syntax try
(syntax-rules ()
((try code exc ... #:finally fin)
(dynamic-wind
(lambda () #f)
(lambda ()
(catch #t
(lambda () code)
(handler (exc ...))))
(lambda ()
(if (not (fluid-ref in-yield))
fin))))
((try code exc ...)
(catch #t
(lambda () code)
(handler (exc ...))))))
(define raise
(case-lambda
(() (raise Exception))
((x)
(if (procedure? x)
(if (procedure-property x 'pyclass)
(throw 'python (x))
(throw 'python x))
(throw 'python x)))))
|
