forked from okuoku/xitomatl
-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathdefine.sls
134 lines (123 loc) · 4.43 KB
/
define.sls
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
#!r6rs
;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named
;; LICENSE from the original collection this file is distributed with.
(library (xitomatl define)
(export
define-values
define/who
define/AV
define/?
define/?/AV)
(import
(rnrs)
(xitomatl define define-values)
(for (only (xitomatl macro-utils) syntax->list) expand)
(only (xitomatl common) format)
(only (xitomatl exceptions) assertion-violation/conditions)
(xitomatl conditions))
(define-syntax who-wrap
(lambda (stx)
(syntax-case stx ()
((_ ctxt name expr)
(with-syntax ((who (datum->syntax #'ctxt 'who)))
#'(let ((who 'name))
#F ;; prevent internal defines in expr
expr))))))
(define-syntax define/who
(lambda (stx)
(syntax-case stx ()
((_ (fname . frmls) b0 b ...)
(identifier? #'fname)
#'(define/who fname
(lambda frmls b0 b ...)))
((_ name expr)
(identifier? #'name)
#'(define name
(who-wrap name name
expr))))))
(define (make-AV who)
(lambda (msg . irrts)
(apply assertion-violation who msg irrts)))
(define-syntax AV-wrap
(lambda (stx)
(syntax-case stx ()
((_ ctxt name expr)
(with-syntax ((AV (datum->syntax #'ctxt 'AV)))
#'(let ((AV (make-AV 'name)))
#F ;; prevent internal defines in expr
expr))))))
(define-syntax define/AV
(lambda (stx)
(syntax-case stx ()
((_ (fname . frmls) b0 b ...)
(identifier? #'fname)
#'(define/AV fname
(lambda frmls b0 b ...)))
((_ name expr)
(identifier? #'name)
#'(define name
(AV-wrap name name
expr))))))
(define (make-arg-check-failed who)
(lambda (pred-form arg-name arg-value)
(assertion-violation/conditions who "argument check failed" (list arg-value)
(make-argument-name-condition arg-name)
(make-predicate-expression-condition pred-form))))
(define-syntax case-lambda/?--meta
(lambda (stx)
(define (frml-id frml)
(syntax-case frml () ((id pred) #'id) (_ frml)))
(define (needs-check? frml)
(syntax-case frml () ((id pred) #T) (_ #F)))
(syntax-case stx ()
((_ fname (frmls . body) ...)
(with-syntax ((((f ... fr) ...)
(map (lambda (f)
(syntax-case f ()
((f ... . #(r p)) #'(f ... (r p)))
((f ... . r) #'(f ... r))))
#'(frmls ...))))
(with-syntax ((((id ... idr) ...)
(map (lambda (fl) (map frml-id (syntax->list fl)))
#'((f ... fr) ...)))
((((cid p) ...) ...)
(map (lambda (fl) (filter needs-check? (syntax->list fl)))
#'((f ... fr) ...))))
#'(let ((acf (make-arg-check-failed 'fname)))
(case-lambda
((id ... . idr)
(unless (p cid) (acf 'p 'cid cid))
...
(let () . body))
...))))))))
(define-syntax define/?
(lambda (stx)
(syntax-case stx ()
((_ (fname . frmls) body0 body* ...)
(identifier? #'fname)
#'(define fname
(case-lambda/?--meta fname (frmls body0 body* ...))))
((_ name expr)
(identifier? #'name)
(with-syntax ((CL/? (datum->syntax #'name 'case-lambda/?))
(L/? (datum->syntax #'name 'lambda/?)))
#'(define name
(let-syntax ((CL/? (syntax-rules ()
((_ . r) (case-lambda/?--meta name . r))))
(L/? (syntax-rules ()
((_ . r) (case-lambda/?--meta name r)))))
expr)))))))
(define-syntax define/?/AV
(lambda (stx)
(syntax-case stx ()
((_ (fname . frmls) body0 body* ...)
(identifier? #'fname)
#'(define fname
(AV-wrap fname fname
(case-lambda/?--meta fname (frmls body0 body* ...)))))
((_ name expr)
(identifier? #'name)
#'(define/? name
(AV-wrap name name
expr))))))
)