blob: 908adea503652fe61d9f41b715e0c179b6d1e7a4 (
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
176
177
178
179
180
|
;;; print-valdefs.scm -- print AST structures for local declarations
;;;
;;; author : Sandra Loosemore
;;; date : 14 Jan 1992
;;;
;;; This file corresponds to ast/valdef-structs.scm.
;;;
;;;
(define-ast-printer signdecl (object xp)
(with-ast-block (xp)
(write-delimited-list (signdecl-vars object) xp (function write) "," "" "")
(write-string " ::" xp)
(write-whitespace xp)
(write (signdecl-signature object) xp)))
;;; This interacts with the layout rule stuff. See util.scm.
(define-ast-printer valdef (object xp)
(let ((lhs (valdef-lhs object))
(definitions (valdef-definitions object)))
(write-definition lhs (car definitions) xp)
(dolist (d (cdr definitions))
(if (dynamic *print-pretty*)
(pprint-newline 'mandatory xp)
(write-string "; " xp))
(write-definition lhs d xp))))
(define (write-definition lhs d xp)
(with-ast-block (xp)
(let ((args (single-fun-def-args d))
(rhs-list (single-fun-def-rhs-list d))
(where-decls (single-fun-def-where-decls d))
(infix? (single-fun-def-infix? d)))
(write-lhs lhs args infix? xp)
(write-rhs rhs-list xp)
(write-wheredecls where-decls xp)
)))
(define (write-lhs lhs args infix? xp)
(cond ((null? args)
;; pattern definition
(write-apat lhs xp)
)
;; If there are args, the lhs is always a var-pat pointing to a
;; var-ref. The infix? slot from the single-fun-def must override
;; the slot on the var-ref, since there can be a mixture of
;; infix and prefix definitions for the same lhs.
(infix?
;; operator definition
(when (not (null? (cddr args)))
(write-char #\( xp))
(write-apat (car args) xp)
(write-whitespace xp)
(write-varop (var-ref-name (var-pat-var lhs)) xp)
(write-whitespace xp)
(write-apat (cadr args) xp)
(when (not (null? (cddr args)))
(write-char #\) xp)
(write-whitespace xp)
(write-delimited-list (cddr args) xp (function write-apat)
"" "" "")))
(else
;; normal prefix function definition
(write-varid (var-ref-name (var-pat-var lhs)) xp)
(write-whitespace xp)
(write-delimited-list args xp (function write-apat) "" "" ""))
))
(define (write-rhs rhs-list xp)
(let ((guard (guarded-rhs-guard (car rhs-list)))
(rhs (guarded-rhs-rhs (car rhs-list))))
(when (not (is-type? 'omitted-guard guard))
(write-string " | " xp)
(write guard xp))
(write-string " =" xp)
(write-whitespace xp)
(write rhs xp)
(when (not (null? (cdr rhs-list)))
(write-newline xp)
(write-rhs (cdr rhs-list) xp))))
;;; Pattern printers
;;; As per jcp suggestion, don't put whitespace after @; line break comes
;;; before, not after (as is the case for other infix-style punctuation).
(define-ast-printer as-pat (object xp)
(with-ast-block (xp)
(write (as-pat-var object) xp)
(write-whitespace xp)
(write-string "@" xp)
(write-apat (as-pat-pattern object) xp)))
(define (write-apat pat xp)
(if (or (is-type? 'apat pat)
(is-type? 'pp-pat-plus pat) ; hack per jcp
(and (is-type? 'pcon pat)
(or (null? (pcon-pats pat))
(eq? (pcon-con pat) (core-symbol "UnitConstructor"))
(is-tuple-constructor? (pcon-con pat)))))
(write pat xp)
(begin
(write-char #\( xp)
(write pat xp)
(write-char #\) xp))))
(define-ast-printer irr-pat (object xp)
(write-string "~" xp)
(write-apat (irr-pat-pattern object) xp))
(define-ast-printer var-pat (object xp)
(write (var-pat-var object) xp))
(define-ast-printer wildcard-pat (object xp)
(declare (ignore object))
(write-char #\_ xp))
(define-ast-printer const-pat (object xp)
(write (const-pat-value object) xp))
(define-ast-printer plus-pat (object xp)
(write (plus-pat-pattern object) xp)
(write-string " + " xp)
(write (plus-pat-k object) xp))
(define-ast-printer pcon (object xp)
(let ((name (pcon-name object))
(pats (pcon-pats object))
(infix? (pcon-infix? object))
(def (pcon-con object)))
(cond ((eq? def (core-symbol "UnitConstructor"))
(write-string "()" xp))
((is-tuple-constructor? def)
(write-commaized-list pats xp))
((null? pats)
(if infix?
;; infix pcon with no arguments can happen inside pp-pat-list
;; before precedence parsing happens.
(write-conop name xp)
(write-conid name xp)))
(infix?
;; This could be smarter about dealing with precedence of patterns.
(with-ast-block (xp)
(write-apat (car pats) xp)
(write-whitespace xp)
(write-conop name xp)
(write-whitespace xp)
(write-apat (cadr pats) xp)))
(else
(with-ast-block (xp)
(write-conid name xp)
(write-whitespace xp)
(write-delimited-list pats xp (function write-apat) "" "" "")))
)))
(define-ast-printer list-pat (object xp)
(write-delimited-list
(list-pat-pats object) xp (function write) "," "[" "]"))
(define-ast-printer pp-pat-list (object xp)
(write-delimited-list (pp-pat-list-pats object) xp (function write-apat)
"" "" ""))
(define-ast-printer pp-pat-plus (object xp)
(declare (ignore object))
(write-string "+ " xp))
(define-ast-printer pp-pat-negated (object xp)
(declare (ignore object))
(write-string "-" xp))
|
