blob: bf924b569d126b0e5a65a5888bc7a50a76ffcb50 (
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
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
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
;;; File: decl-parser Author: John
(define (parse-decl)
(let ((decl-type (find-decl-type)))
(cond ((eq? decl-type 'signdecl)
(parse-signdecl))
((eq? decl-type 'pat-or-op)
(parse-pat-or-op))
((eq? decl-type 'fundef)
(parse-fundef))
((eq? decl-type 'plus-def)
(parse-plus-def))
((eq? decl-type 'annotation)
(make annotation-decls (annotations (parse-annotations)))))))
;;; This looks at the first tokens in a definition to determine it's type.
;;; var (:: | ,) - signdecl
;;; var apat-start - function definition
;;; (var | _) + - definition of infix +
;;; anything alse - pattern binding or infix definition
(define (find-decl-type)
(let* ((saved-excursion (save-scanner-state))
(decl-type
(token-case
(var (scan-var)
(token-case
((\, \:\:) 'signdecl)
(apat-start 'fundef)
(+ 'plus-def)
(else 'pat-or-op)))
(_ (token-case
(+ 'plus-def)
(else 'pat-or-op)))
(begin-annotation 'annotation)
(else 'pat-or-op))))
(restore-excursion saved-excursion)
decl-type))
;;; These are the different flavors of decl parsers
(define (parse-signdecl)
(save-parser-context
(trace-parser signdecl
(let ((vars (parse-signdecl-vars)))
(require-token \:\:
(signal-missing-token "`::'" "signature declaration"))
(let ((signature (parse-signature)))
(make signdecl (vars vars) (signature signature)))))))
(define (parse-signdecl-vars)
(token-case
(var (let ((var (var->ast)))
(token-case (\, (cons var (parse-signdecl-vars)))
(else (list var)))))
(else (signal-missing-token "<var>" "signature declaration"))))
(define (parse-pat-or-op)
(trace-parser patdef
(let* ((line-number (capture-current-line))
(pat (parse-pat)))
(token-case
(varop (parse-infix-def pat line-number))
(else (add-rhs pat '() '#f line-number))))))
(define (parse-infix-def pat1 line-number)
(let* ((op (make var-pat (var (varop->ast))))
(pat2 (parse-pat)))
(add-rhs op (list pat1 pat2) '#t line-number)))
(define (parse-fundef)
(trace-parser fundef
(let* ((start-line (capture-current-line))
(fn (parse-apat)) ; must be a single variable
(args (parse-apat-list)))
(add-rhs fn args '#f start-line))))
(define (parse-plus-def)
(trace-parser plus-def
(let* ((start-line (capture-current-line))
(var (parse-apat)))
(parse-infix-def var start-line))))
(define (add-rhs pat args infix? start-line)
(let* ((rhs (parse-rhs))
(decls (parse-where-decls))
(single (make single-fun-def
(args args)
(rhs-list rhs)
(where-decls decls)
(infix? infix?)))
(valdef (make valdef (lhs pat) (definitions (list single)))))
(setf (ast-node-line-number single) start-line)
(setf (ast-node-line-number valdef) start-line)
valdef))
(define (parse-rhs)
(token-case
(= (let ((rhs (parse-exp)))
(list (make guarded-rhs (guard (make omitted-guard)) (rhs rhs)))))
(\| (parse-guarded-rhs))
(else
(signal-missing-token "`=' or `|'" "rhs of valdef"))))
(define (parse-guarded-rhs) ; assume just past |
(trace-parser guard
(let ((guard (parse-exp-i))) ; 1.2 change
(require-token = (signal-missing-token "`='" "guarded rhs"))
(let* ((exp (parse-exp))
(res (make guarded-rhs (guard guard) (rhs exp))))
(token-case
(\| (cons res (parse-guarded-rhs)))
(else (list res)))))))
(define (parse-where-decls)
(token-case
(|where|
(parse-decl-list))
(else '())))
(define (parse-decl-list)
(start-layout (function parse-decl-list-1)))
(define (parse-decl-list-1 in-layout?)
(token-case
((apat-start begin-annotation)
(let ((decl (parse-decl)))
(token-case
(\; (decl-cons decl (parse-decl-list-1 in-layout?)))
(else (close-layout in-layout?)
(list decl)))))
(else
(close-layout in-layout?)
'())))
;;; This adds a new decl to a decl list. Successive decls for the same fn
;;; are combined.
(define (decl-cons decl decl-list)
(cond ((null? decl-list)
(list decl))
(else (nconc (combine-decls decl (car decl-list)) (cdr decl-list)))))
(define (decl-push decl decl-stack)
(cond ((null? decl-stack)
(list decl))
(else (nconc (nreverse (combine-decls (car decl-stack) decl))
(cdr decl-stack)))))
(define (combine-decls decl1 decl2)
(if (and (is-type? 'valdef decl1)
(is-type? 'valdef decl2)
(same-decl-var? (valdef-lhs decl1) (valdef-lhs decl2)))
(if (eqv? (length (single-fun-def-args (car (valdef-definitions decl1))))
(length (single-fun-def-args (car (valdef-definitions decl2)))))
(begin
(setf (valdef-definitions decl1)
(nconc (valdef-definitions decl1)
(valdef-definitions decl2)))
(list decl1))
(signal-multiple-definitions-arity-mismatch (valdef-lhs decl1)))
(list decl1 decl2)))
(define (same-decl-var? pat1 pat2)
(and (is-type? 'var-pat pat1)
(is-type? 'var-pat pat2)
(eq? (var-ref-name (var-pat-var pat1))
(var-ref-name (var-pat-var pat2)))))
(define (signal-multiple-definitions-arity-mismatch pat)
(parser-error 'multiple-definitions-arity-mismatch
"Definition of ~a does not match arity of previous definition."
pat))
|
