forked from mighty-gerbils/gerbil
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathsugar.ss
134 lines (119 loc) · 4.12 KB
/
sugar.ss
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
;;; -*- Gerbil -*-
;;; (C) vyzo
;;; some standard sugar
package: std
(export #t)
(defrules catch ())
(defrules finally ())
(defsyntax (try stx)
(def (generate-thunk body)
(if (null? body)
(raise-syntax-error #f "Bad syntax; missing body" stx)
(with-syntax (((e ...) (reverse body)))
#'(lambda () e ...))))
(def (generate-fini thunk fini)
(with-syntax ((thunk thunk)
((e ...) fini))
#'(with-unwind-protect thunk (lambda () e ...))))
(def (generate-catch handlers thunk)
(with-syntax (($e (genident)))
(let lp ((rest handlers) (clauses []))
(match rest
([hd . rest]
(syntax-case hd (=>)
((pred => K)
(lp rest (cons #'(((? pred) $e) => K)
clauses)))
(((pred var) body ...)
(identifier? #'var)
(lp rest (cons #'(((? pred) $e) (let ((var $e)) body ...))
clauses)))
(((var) body ...)
(identifier? #'var)
(lp rest (cons #'(#t (let ((var $e)) body ...))
clauses)))
((us body ...)
(underscore? #'us)
(lp rest (cons #'(#t (begin body ...))
clauses)))))
(else
(with-syntax (((clause ...) clauses)
(thunk thunk))
#'(with-catch
(lambda ($e) (cond clause ... (else (raise $e))))
thunk)))))))
(syntax-case stx ()
((_ e ...)
(let lp ((rest #'(e ...)) (body []))
(syntax-case rest ()
((hd . rest)
(syntax-case #'hd (catch finally)
((finally fini ...)
(if (stx-null? #'rest)
(generate-fini (generate-thunk body) #'(fini ...))
(raise-syntax-error #f "Misplaced finally clause" stx)))
((catch handler ...)
(let lp ((rest #'rest) (handlers [#'(handler ...)]))
(syntax-case rest (catch finally)
(((catch handler ...) . rest)
(lp #'rest [#'(handler ...) . handlers]))
(((finally fini ...))
(with-syntax ((body (generate-catch handlers (generate-thunk body))))
(generate-fini #'(lambda () body) #'(fini ...))))
(()
(generate-catch handlers (generate-thunk body))))))
(_ (lp #'rest (cons #'hd body)))))
(() ; no clauses, just a begin
(cons 'begin (reverse body))))))))
(defrules with-destroy ()
((_ obj body ...)
(let ($obj obj)
(try body ... (finally {destroy $obj})))))
(defsyntax (defmethod/alias stx)
(syntax-case stx (@method)
((_ {method (alias ...) type} body ...)
(and (identifier? #'method)
(stx-andmap identifier? #'(alias ...))
(syntax-local-type-info? #'type))
(with-syntax* (((values klass) (syntax-local-value #'type))
(type::t (runtime-type-identifier klass))
(method-impl (stx-identifier #'method #'type "::" #'method)))
#'(begin
(defmethod {method type} body ...)
(bind-method! type::t 'alias method-impl) ...)))))
(defrules assert! ()
((_ expr)
(unless expr
(error "Assertion failed" 'expr)))
((_ expr message)
(unless expr
(error "Assertion failed" message 'expr))))
(defrules while ()
((_ test body ...)
(let lp ()
(when test
body ...
(lp)))))
(defrules until ()
((_ test body ...)
(let lp ()
(unless test
body ...
(lp)))))
(defrules hash ()
((_ (key val) ...)
(~hash-table make-hash-table (key val) ...)))
(defrules hash-eq ()
((_ (key val) ...)
(~hash-table make-hash-table-eq (key val) ...)))
(defrules hash-eqv ()
((_ (key val) ...)
(~hash-table make-hash-table-eqv (key val) ...)))
(defsyntax (~hash-table stx)
(syntax-case stx ()
((_ make-ht clause ...)
(with-syntax* ((size (stx-length #'(clause ...)))
(((key val) ...) #'(clause ...)))
#'(let (ht (make-ht size: size))
(hash-put! ht `key val) ...
ht)))))