From 3a40125168927577d3fca7a2049179d52ce06036 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 24 Feb 2018 21:26:08 +0100 Subject: [PATCH] add arity checks for log-expand, fix some uses --- racket/src/expander/expand/body.rkt | 4 +- racket/src/expander/expand/log.rkt | 179 +++++++++++++------------- racket/src/expander/expand/module.rkt | 14 +- 3 files changed, 103 insertions(+), 94 deletions(-) diff --git a/racket/src/expander/expand/body.rkt b/racket/src/expander/expand/body.rkt index 5ca8bd6e84..04ad4c4fd6 100644 --- a/racket/src/expander/expand/body.rkt +++ b/racket/src/expander/expand/body.rkt @@ -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)])])) diff --git a/racket/src/expander/expand/log.rkt b/racket/src/expander/expand/log.rkt index 7530ae16fc..c7944091e3 100644 --- a/racket/src/expander/expand/log.rkt +++ b/racket/src/expander/expand/log.rkt @@ -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)))) diff --git a/racket/src/expander/expand/module.rkt b/racket/src/expander/expand/module.rkt index 83bd9bef48..41f686b51b 100644 --- a/racket/src/expander/expand/module.rkt +++ b/racket/src/expander/expand/module.rkt @@ -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)