suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add arity checks for log-expand, fix some uses

Browse Source
This commit is contained in:
Ryan Culpepper 2018-02-24 21:26:08 +01:00 committed by Matthew Flatt
parent ed3d2d0082
commit 3a40125168
3 changed files with 103 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/src/expander/expand/body.rkt
View File

@ -437,7 +437,7 @@
(cond (cond
[had-stxes? [had-stxes?
(...log-expand obs (...log-expand obs
['prim-letrec-syntaxes+values #f] ['prim-letrec-syntaxes+values]
['letrec-syntaxes-renames stx-clauses clauses (datum->syntax #f done-bodys s)] ['letrec-syntaxes-renames stx-clauses clauses (datum->syntax #f done-bodys s)]
['prepare-env] ['prepare-env]
['next-group]) ['next-group])
@ -447,5 +447,5 @@
['let-renames clauses (datum->syntax #f done-bodys s)]))] ['let-renames clauses (datum->syntax #f done-bodys s)]))]
[else [else
(...log-expand obs (...log-expand obs
['prim-letrec-values #f] ['prim-letrec-values]
['let-renames clauses (datum->syntax #f done-bodys s)])])) ['let-renames clauses (datum->syntax #f done-bodys s)])]))

179
racket/src/expander/expand/log.rkt
View File

@ -35,9 +35,15 @@
(log-expand* ctx #:when #t [key arg ...])) (log-expand* ctx #:when #t [key arg ...]))
(define (call-expand-observe obs key . args) (define (call-expand-observe obs key . args)
(obs (hash-ref key->number key) (cond (cond [(hash-ref key->number+arity key)
[(null? args) #f] => (lambda (number+arity)
[else (apply list* args)]))) (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 (log-expand-start)
(define obs (current-expand-observe)) (define obs (current-expand-observe))
@ -46,109 +52,110 @@
;; For historical reasons, an expander observer currently expects ;; For historical reasons, an expander observer currently expects
;; numbers ;; numbers
(define key->number (define key->number+arity
#hash((visit . 0) ;; event-symbol => (event-num . #args)
(resolve . 1) #hash((visit . (0 . 1))
(return . 2) (resolve . (1 . 1))
(next . 3) (return . (2 . 1))
(enter-list . 4) (next . (3 . 0))
(exit-list . 5) (enter-list . (4 . 1))
(enter-prim . 6) (exit-list . (5 . 1))
(exit-prim . 7) (enter-prim . (6 . 1))
(enter-macro . 8) (exit-prim . (7 . 1))
(exit-macro . 9) (enter-macro . (8 . 1))
(enter-block . 10) (exit-macro . (9 . 1))
(splice . 11) (enter-block . (10 . 1))
(block->list . 12) (splice . (11 . 1))
(next-group . 13) (block->list . (12 . 1))
(block->letrec . 14) (next-group . (13 . 0))
(let-renames . 16) (block->letrec . (14 . 1))
(lambda-renames . 17) (let-renames . (16 . #f)) ;; renames consed by expander... sometimes
(case-lambda-renames . 18) (lambda-renames . (17 . 2))
(letrec-syntaxes-renames . 19) (case-lambda-renames . (18 . 2))
(phase-up . 20) (letrec-syntaxes-renames . (19 . #f)) ;; renames consed by expander... sometimes
(phase-up . (20 . 0))
(macro-pre-x . 21) (macro-pre-x . (21 . 1))
(macro-post-x . 22) (macro-post-x . (22 . 2))
(module-body . 23) (module-body . (23 . 1))
(block-renames . 24) (block-renames . (24 . 2))
(prim-stop . 100) (prim-stop . (100 . 0))
(prim-module . 101) (prim-module . (101 . 0))
(prim-module-begin . 102) (prim-module-begin . (102 . 0))
(prim-define-syntaxes . 103) (prim-define-syntaxes . (103 . 0))
(prim-define-values . 104) (prim-define-values . (104 . 0))
(prim-if . 105) (prim-if . (105 . 0))
(prim-with-continuation-mark . 106) (prim-with-continuation-mark . (106 . 0))
(prim-begin . 107) (prim-begin . (107 . 0))
(prim-begin0 . 108) (prim-begin0 . (108 . 0))
(prim-#%app . 109) (prim-#%app . (109 . 0))
(prim-lambda . 110) (prim-lambda . (110 . 0))
(prim-case-lambda . 111) (prim-case-lambda . (111 . 0))
(prim-let-values . 112) (prim-let-values . (112 . 0))
(prim-letrec-values . 113) (prim-letrec-values . (113 . 0))
(prim-letrec-syntaxes+values . 114) (prim-letrec-syntaxes+values . (114 . 0))
(prim-#%datum . 115) (prim-#%datum . (115 . 0))
(prim-#%top . 116) (prim-#%top . (116 . 0))
(prim-quote . 117) (prim-quote . (117 . 0))
(prim-quote-syntax . 118) (prim-quote-syntax . (118 . 0))
(prim-require . 119) (prim-require . (119 . 0))
(prim-provide . 122) (prim-provide . (122 . 0))
(prim-set! . 123) (prim-set! . (123 . 0))
(prim-#%expression . 138) (prim-#%expression . (138 . 0))
(prim-#%variable-reference . 149) (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 . (158 . 0))
(prim-submodule* . 159) (prim-submodule* . (159 . 0))
(variable . 125) (variable . (125 . 2))
(enter-check . 126) (enter-check . (126 . 1))
(exit-check . 127) (exit-check . (127 . 1))
(lift-loop . 128) (lift-loop . (128 . 1))
(letlift-loop . 136) (letlift-loop . (136 . 1))
(module-lift-loop . 137) (module-lift-loop . (137 . 1))
(module-lift-end-loop . 135) (module-lift-end-loop . (135 . 1))
(local-lift . 129) (local-lift . (129 . 2))
(lift-statement . 134) (lift-statement . (134 . 1))
(lift-require . 150) (lift-require . (150 . 3))
(lift-provide . 151) (lift-provide . (151 . 1))
(enter-local . 130) (enter-local . (130 . 1))
(exit-local . 131) (exit-local . (131 . 1))
(local-pre . 132) (local-pre . (132 . 1))
(local-post . 133) (local-post . (133 . 1))
(enter-local-expr . 139) (enter-local-expr . (139 . 1))
(exit-local-expr . 140) (exit-local-expr . (140 . 2))
(start-expand . 141) (start-expand . (141 . 0))
(tag . 142) (tag . (142 . 1))
(local-bind . 143) (local-bind . (143 . 1))
(exit-local-bind . 160) (exit-local-bind . (160 . 0))
(enter-bind . 144) (enter-bind . (144 . 0))
(exit-bind . 145) (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))))

14
racket/src/expander/expand/module.rkt
View File

@ -1073,16 +1073,18 @@
[namespace (namespace->namespace-at-phase m-ns phase)] [namespace (namespace->namespace-at-phase m-ns phase)]
[requires+provides requires+provides] [requires+provides requires+provides]
[declared-submodule-names declared-submodule-names]))) [declared-submodule-names declared-submodule-names])))
(log-expand ctx 'exit-prim)
(cond (cond
[(expand-context-to-parsed? ctx) [(expand-context-to-parsed? ctx)
(loop (cdr bodys) phase)] (loop (cdr bodys) phase)]
[else [else
(cons (syntax-track-origin* (define new-s
track-stxes (syntax-track-origin*
(rebuild track-stxes
(car bodys) (rebuild
`(,(m '#%provide) ,@specs))) (car bodys)
`(,(m '#%provide) ,@specs))))
(log-expand ctx 'exit-prim new-s)
(cons new-s
(loop (cdr bodys) phase))])] (loop (cdr bodys) phase))])]
[else [else
(cons (car bodys) (cons (car bodys)