-
Notifications
You must be signed in to change notification settings - Fork 3
/
syntaxcasexformboot.scm
100 lines (82 loc) · 4.33 KB
/
syntaxcasexformboot.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
;;;============================================================================
;;; File: "syntaxcasexformboot.scm"
;;; Copyright (c) 2000-2014 by Marc Feeley, All Rights Reserved.
;;;============================================================================
;; This file implements an unhygienic version of the (syntax-case ...)
;; form that is used for bootstrapping.
;;;----------------------------------------------------------------------------
(define (syn#syntax-case-form-transformer src)
(define-macro (syntax-case-cpattern)
(include "syntaxpattern.scm") ;; get definition of syn#compile-pattern
(syn#compile-pattern
(##make-source '(_ input (literal ...) (pattern guard expr ...) ...) #f)
'()
(lambda (cpattern pvars)
`',cpattern)))
(include "syntaxpattern.scm") ;; get definitions of syn#match-pattern, etc
(include "syntaxcommon.scm") ;; get definition of syn#pvar-id
(let ((bs (syn#match-pattern (syntax-case-cpattern) src)))
(if (syn#match-success? bs)
(let* ((input (vector-ref bs 0))
(literals (map ##source-code (vector->list (vector-ref bs 1))))
(patterns (vector-ref bs 2))
(guards (vector-ref bs 3))
(exprss (vector-ref bs 4))
(fn-names
(list->vector
(map (lambda (x) (gensym 'case))
(cons 'dummy (vector->list patterns)))))
(len (vector-length patterns)))
(let loop ((i
(- len 1))
(fns
`((,(vector-ref fn-names len)
(##lambda (##failures)
(error "syntax error" ##failures))))))
(if (< i 0)
`(##let ((##src ,input))
(##letrec ,fns
(,(vector-ref fn-names 0) '())))
(let ((pattern (vector-ref patterns i))
(guard (vector-ref guards i))
(exprs (vector-ref exprss i)))
(syn#compile-pattern
(##sourcify pattern src)
literals
(lambda (cpattern pvars)
(define (bind-pattern-variables vals)
`(##let ,(map (lambda (pvar val)
(list (syn#pvar-id pvar) val))
pvars
vals)
(syntax
##let-pattern-variables
,pvars
,(if (= 0 (vector-length exprs))
guard
`(##if ,guard
(##let ()
,@(vector->list exprs))
(,(vector-ref fn-names (+ i 1))
##failures))))))
(loop (- i 1)
(cons `(,(vector-ref fn-names i)
(##lambda (##failures)
,(if (syn#pattern-pvar? cpattern)
;; optimize for pattern = single var
(bind-pattern-variables
'(##src))
;; general case uses syn#match-pattern
`(##let ((##bs (syn#match-pattern ',cpattern ##src)))
(##if (syn#match-success? ##bs)
,(bind-pattern-variables
(map (lambda (pvar)
`(##vector-ref
##bs
,(cadr pvar)))
pvars))
(,(vector-ref fn-names (+ i 1))
(##cons ##bs ##failures)))))))
fns))))))))
(error "illformed syntax-case"))))
;;;============================================================================