add arity checks for log-expand, fix some uses
This commit is contained in:
Ryan Culpepper
Matthew Flatt
parent
ed3d2d0082
commit
3a40125168
|
|
@ -437,7 +437,7 @@
|
|||
(cond
|
||||
[had-stxes?
|
||||
(...log-expand obs
|
||||
['prim-letrec-syntaxes+values #f]
|
||||
['prim-letrec-syntaxes+values]
|
||||
['letrec-syntaxes-renames stx-clauses clauses (datum->syntax #f done-bodys s)]
|
||||
['prepare-env]
|
||||
['next-group])
|
||||
|
|
@ -447,5 +447,5 @@
|
|||
['let-renames clauses (datum->syntax #f done-bodys s)]))]
|
||||
[else
|
||||
(...log-expand obs
|
||||
['prim-letrec-values #f]
|
||||
['prim-letrec-values]
|
||||
['let-renames clauses (datum->syntax #f done-bodys s)])]))
|
||||
|
|
|
|||
|
|
@ -35,9 +35,15 @@
|
|||
(log-expand* ctx #:when #t [key arg ...]))
|
||||
|
||||
(define (call-expand-observe obs key . args)
|
||||
(obs (hash-ref key->number key) (cond
|
||||
[(null? args) #f]
|
||||
[else (apply list* args)])))
|
||||
(cond [(hash-ref key->number+arity key)
|
||||
=> (lambda (number+arity)
|
||||
(let ([arity (cdr number+arity)])
|
||||
(unless (or (not arity) (= (length args) arity))
|
||||
(error 'call-expand-observe "wrong arity for ~s: ~e" key args)))
|
||||
(obs (car number+arity)
|
||||
(cond [(null? args) #f]
|
||||
[else (apply list* args)])))]
|
||||
[else (error 'call-expand-observe "bad key: ~s" key)]))
|
||||
|
||||
(define (log-expand-start)
|
||||
(define obs (current-expand-observe))
|
||||
|
|
@ -46,109 +52,110 @@
|
|||
|
||||
;; For historical reasons, an expander observer currently expects
|
||||
;; numbers
|
||||
(define key->number
|
||||
#hash((visit . 0)
|
||||
(resolve . 1)
|
||||
(return . 2)
|
||||
(next . 3)
|
||||
(enter-list . 4)
|
||||
(exit-list . 5)
|
||||
(enter-prim . 6)
|
||||
(exit-prim . 7)
|
||||
(enter-macro . 8)
|
||||
(exit-macro . 9)
|
||||
(enter-block . 10)
|
||||
(splice . 11)
|
||||
(block->list . 12)
|
||||
(next-group . 13)
|
||||
(block->letrec . 14)
|
||||
(let-renames . 16)
|
||||
(lambda-renames . 17)
|
||||
(case-lambda-renames . 18)
|
||||
(letrec-syntaxes-renames . 19)
|
||||
(phase-up . 20)
|
||||
(define key->number+arity
|
||||
;; event-symbol => (event-num . #args)
|
||||
#hash((visit . (0 . 1))
|
||||
(resolve . (1 . 1))
|
||||
(return . (2 . 1))
|
||||
(next . (3 . 0))
|
||||
(enter-list . (4 . 1))
|
||||
(exit-list . (5 . 1))
|
||||
(enter-prim . (6 . 1))
|
||||
(exit-prim . (7 . 1))
|
||||
(enter-macro . (8 . 1))
|
||||
(exit-macro . (9 . 1))
|
||||
(enter-block . (10 . 1))
|
||||
(splice . (11 . 1))
|
||||
(block->list . (12 . 1))
|
||||
(next-group . (13 . 0))
|
||||
(block->letrec . (14 . 1))
|
||||
(let-renames . (16 . #f)) ;; renames consed by expander... sometimes
|
||||
(lambda-renames . (17 . 2))
|
||||
(case-lambda-renames . (18 . 2))
|
||||
(letrec-syntaxes-renames . (19 . #f)) ;; renames consed by expander... sometimes
|
||||
(phase-up . (20 . 0))
|
||||
|
||||
(macro-pre-x . 21)
|
||||
(macro-post-x . 22)
|
||||
(macro-pre-x . (21 . 1))
|
||||
(macro-post-x . (22 . 2))
|
||||
|
||||
(module-body . 23)
|
||||
(block-renames . 24)
|
||||
(module-body . (23 . 1))
|
||||
(block-renames . (24 . 2))
|
||||
|
||||
(prim-stop . 100)
|
||||
(prim-module . 101)
|
||||
(prim-module-begin . 102)
|
||||
(prim-define-syntaxes . 103)
|
||||
(prim-define-values . 104)
|
||||
(prim-if . 105)
|
||||
(prim-with-continuation-mark . 106)
|
||||
(prim-begin . 107)
|
||||
(prim-begin0 . 108)
|
||||
(prim-#%app . 109)
|
||||
(prim-lambda . 110)
|
||||
(prim-case-lambda . 111)
|
||||
(prim-let-values . 112)
|
||||
(prim-letrec-values . 113)
|
||||
(prim-letrec-syntaxes+values . 114)
|
||||
(prim-#%datum . 115)
|
||||
(prim-#%top . 116)
|
||||
(prim-quote . 117)
|
||||
(prim-quote-syntax . 118)
|
||||
(prim-require . 119)
|
||||
(prim-provide . 122)
|
||||
(prim-stop . (100 . 0))
|
||||
(prim-module . (101 . 0))
|
||||
(prim-module-begin . (102 . 0))
|
||||
(prim-define-syntaxes . (103 . 0))
|
||||
(prim-define-values . (104 . 0))
|
||||
(prim-if . (105 . 0))
|
||||
(prim-with-continuation-mark . (106 . 0))
|
||||
(prim-begin . (107 . 0))
|
||||
(prim-begin0 . (108 . 0))
|
||||
(prim-#%app . (109 . 0))
|
||||
(prim-lambda . (110 . 0))
|
||||
(prim-case-lambda . (111 . 0))
|
||||
(prim-let-values . (112 . 0))
|
||||
(prim-letrec-values . (113 . 0))
|
||||
(prim-letrec-syntaxes+values . (114 . 0))
|
||||
(prim-#%datum . (115 . 0))
|
||||
(prim-#%top . (116 . 0))
|
||||
(prim-quote . (117 . 0))
|
||||
(prim-quote-syntax . (118 . 0))
|
||||
(prim-require . (119 . 0))
|
||||
(prim-provide . (122 . 0))
|
||||
|
||||
(prim-set! . 123)
|
||||
(prim-#%expression . 138)
|
||||
(prim-#%variable-reference . 149)
|
||||
(prim-set! . (123 . 0))
|
||||
(prim-#%expression . (138 . 0))
|
||||
(prim-#%variable-reference . (149 . 0))
|
||||
|
||||
(prim-#%stratified . 155)
|
||||
(prim-#%stratified . (155 . 0))
|
||||
|
||||
(prim-begin-for-syntax . 156)
|
||||
(prim-begin-for-syntax . (156 . 0))
|
||||
|
||||
(prim-submodule . 158)
|
||||
(prim-submodule* . 159)
|
||||
(prim-submodule . (158 . 0))
|
||||
(prim-submodule* . (159 . 0))
|
||||
|
||||
(variable . 125)
|
||||
(variable . (125 . 2))
|
||||
|
||||
(enter-check . 126)
|
||||
(exit-check . 127)
|
||||
(enter-check . (126 . 1))
|
||||
(exit-check . (127 . 1))
|
||||
|
||||
(lift-loop . 128)
|
||||
(letlift-loop . 136)
|
||||
(module-lift-loop . 137)
|
||||
(module-lift-end-loop . 135)
|
||||
(lift-loop . (128 . 1))
|
||||
(letlift-loop . (136 . 1))
|
||||
(module-lift-loop . (137 . 1))
|
||||
(module-lift-end-loop . (135 . 1))
|
||||
|
||||
(local-lift . 129)
|
||||
(lift-statement . 134)
|
||||
(lift-require . 150)
|
||||
(lift-provide . 151)
|
||||
(local-lift . (129 . 2))
|
||||
(lift-statement . (134 . 1))
|
||||
(lift-require . (150 . 3))
|
||||
(lift-provide . (151 . 1))
|
||||
|
||||
(enter-local . 130)
|
||||
(exit-local . 131)
|
||||
(local-pre . 132)
|
||||
(local-post . 133)
|
||||
(enter-local . (130 . 1))
|
||||
(exit-local . (131 . 1))
|
||||
(local-pre . (132 . 1))
|
||||
(local-post . (133 . 1))
|
||||
|
||||
(enter-local-expr . 139)
|
||||
(exit-local-expr . 140)
|
||||
(enter-local-expr . (139 . 1))
|
||||
(exit-local-expr . (140 . 2))
|
||||
|
||||
(start-expand . 141)
|
||||
(start-expand . (141 . 0))
|
||||
|
||||
(tag . 142)
|
||||
(tag . (142 . 1))
|
||||
|
||||
(local-bind . 143)
|
||||
(exit-local-bind . 160)
|
||||
(enter-bind . 144)
|
||||
(exit-bind . 145)
|
||||
(local-bind . (143 . 1))
|
||||
(exit-local-bind . (160 . 0))
|
||||
(enter-bind . (144 . 0))
|
||||
(exit-bind . (145 . 0))
|
||||
|
||||
(opaque-expr . 146)
|
||||
(opaque-expr . (146 . 1))
|
||||
|
||||
(rename-list . 147)
|
||||
(rename-list . (147 . 1))
|
||||
|
||||
(rename-one . 148)
|
||||
(rename-one . (148 . 1))
|
||||
|
||||
(track-origin . 152)
|
||||
(track-origin . (152 . 2))
|
||||
|
||||
(local-value . 153)
|
||||
(local-value . (153 . 1))
|
||||
|
||||
(local-value-result . 154)
|
||||
(local-value-result . (154 . 1))
|
||||
|
||||
(prepare-env . 157)))
|
||||
(prepare-env . (157 . 0))))
|
||||
|
|
|
|||
|
|
@ -1073,16 +1073,18 @@
|
|||
[namespace (namespace->namespace-at-phase m-ns phase)]
|
||||
[requires+provides requires+provides]
|
||||
[declared-submodule-names declared-submodule-names])))
|
||||
(log-expand ctx 'exit-prim)
|
||||
(cond
|
||||
[(expand-context-to-parsed? ctx)
|
||||
(loop (cdr bodys) phase)]
|
||||
[else
|
||||
(cons (syntax-track-origin*
|
||||
track-stxes
|
||||
(rebuild
|
||||
(car bodys)
|
||||
`(,(m '#%provide) ,@specs)))
|
||||
(define new-s
|
||||
(syntax-track-origin*
|
||||
track-stxes
|
||||
(rebuild
|
||||
(car bodys)
|
||||
`(,(m '#%provide) ,@specs))))
|
||||
(log-expand ctx 'exit-prim new-s)
|
||||
(cons new-s
|
||||
(loop (cdr bodys) phase))])]
|
||||
[else
|
||||
(cons (car bodys)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user