-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathsyntaxcasexform.scm
129 lines (112 loc) · 5.68 KB
/
syntaxcasexform.scm
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
;;;============================================================================
;;; File: "syntaxcasexform.scm"
;;; Copyright (c) 2000-2014 by Marc Feeley, All Rights Reserved.
;;;============================================================================
;; This file implements an unhygienic version of the (syntax-case ...)
;; form.
;;;----------------------------------------------------------------------------
(define (syn#syntax-case-form-transformer src)
(include "syntaxboot.scm") ;; get bootstrap versions of syntax-case and syntax forms
(include "withsyntaxboot.scm") ;; get bootstrap versions of with-syntax
(syntax-case src ()
((_ input (literal ...) (pattern guard expr ...) ...)
(let* ((literals
(syntax->datum #'(literal ...)))
(guards
(syntax->vector #'#(guard ...)))
(patterns
(syntax->vector #'#(pattern ...)))
(exprss
(syntax->vector #'#((expr ...) ...)))
(fn-names
(list->vector
(map (lambda (x) (gensym 'case))
(cons 'dummy (vector->list patterns)))))
(len
(vector-length patterns)))
(let loop ((i
(- len 1))
(fns
(with-syntax ((error-fn
(datum->syntax
src
(vector-ref fn-names len))))
(list #'(error-fn
(##lambda (##failures)
(error "syntax error" ##failures)))))))
(if (< i 0)
(with-syntax ((start-fn
(datum->syntax
src
(vector-ref fn-names 0))))
(with-syntax ((fns
(datum->syntax
src
fns)))
#'(##let ((##src input))
(##letrec fns
(start-fn '())))))
(let ((pattern (vector-ref patterns i))
(guard (vector-ref guards i))
(exprs (vector-ref exprss i)))
(syn#compile-pattern
pattern
literals
(lambda (cpattern pvars)
(define (bind-pattern-variables vals)
(with-syntax ((pvars
(datum->syntax src pvars)))
(with-syntax ((guard
(datum->syntax src guard)))
(with-syntax ((bindings
(datum->syntax
src
(map (lambda (pvar val)
(list (syn#pvar-id pvar) val))
pvars
vals))))
#'(##let bindings
(syntax
##let-pattern-variables
pvars
guard))))))
(define (fn-def)
(with-syntax ((fn-name
(datum->syntax
src
(vector-ref fn-names i))))
(with-syntax ((next-fn-name
(datum->syntax
src
(vector-ref fn-names (+ i 1)))))
(with-syntax ((cpattern
(datum->syntax
src
cpattern)))
(if (syn#pattern-pvar? cpattern)
;; optimize for pattern = single var
(with-syntax ((bind-pvars
(bind-pattern-variables
'(##src))))
#'(fn-name
(##lambda (##failures)
bind-pvars)))
;; general case uses syn#match-pattern
(with-syntax ((bind-pvars
(bind-pattern-variables
(map (lambda (pvar)
`(##vector-ref
##bs
,(cadr pvar)))
pvars))))
#'(fn-name
(##lambda (##failures)
(##let ((##bs (syn#match-pattern 'cpattern ##src)))
(##if (syn#match-success? ##bs)
bind-pvars
(next-fn-name
(##cons ##bs
##failures))))))))))))
(loop (- i 1)
(cons (fn-def) fns)))))))))))
;;;============================================================================