From 0ec71da6145fce4cd012919a2cc260d7766ceecd Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 21 May 2010 15:35:51 -0600 Subject: [PATCH] attach original syntax properties during expansion. add debug syntax classes. --- collects/honu/private/honu-typed-scheme.rkt | 22 +++++- collects/honu/private/macro.rkt | 6 +- collects/honu/private/more.ss | 72 ++++++++++++++++-- collects/honu/private/parse.rkt | 82 ++++++++++++++++----- collects/honu/private/syntax.ss | 6 ++ 5 files changed, 157 insertions(+), 31 deletions(-) diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index f63dbbc23a..3bf514e5c3 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -11,6 +11,7 @@ "contexts.ss" "util.ss" "ops.ss" + "syntax.ss" "parse.ss" ) (for-template scheme/base) @@ -352,9 +353,10 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (lambda (stx ctx) (syntax-parse stx #:literals (semicolon) [(_ word:identifier ... semicolon . rest) - (values (lambda () #'(begin + (values (lambda () (apply-scheme-syntax + #'(begin (define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this"))) - ...)) + ...))) #'rest)]))) (define-honu-syntax honu-if @@ -510,9 +512,21 @@ if (foo){ [(rest ...) rest]) (if (stx-null? #'(rest ...)) (syntax/loc stx - code) + code) + #; + (if (raw-scheme? #'code) + (syntax/loc stx + code) + (with-syntax ([(code* ...) #'code]) + (syntax/loc stx (honu-unparsed-begin code* ...)))) (syntax/loc stx - (begin code (honu-unparsed-begin rest ...)))))))] + (begin code (honu-unparsed-begin rest ...))) + #; + (if (raw-scheme? #'code) + (syntax/loc stx + (begin code (honu-unparsed-begin rest ...))) + (with-syntax ([(code* ...) #'code]) + (syntax/loc stx (honu-unparsed-begin code* ... rest ...))))))))] #; [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context #'body diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 93e2a0f5e3..fe440d0b44 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -11,6 +11,7 @@ (for-syntax "debug.ss" "contexts.ss" "parse.ss" + "syntax.ss" "honu-typed-scheme.ss" scheme/base syntax/parse @@ -439,7 +440,8 @@ (let ([result (honu-unparsed-begin code ...)]) (lambda () result)) #'(rrest (... ...)))]))) - (printf "Original pattern ~a" (syntax->datum #'(fixed ... rrest (... ...)))) + (printf "Original pattern ~a\n" (syntax->datum #'(fixed ... rrest (... ...)))) + (apply-scheme-syntax (syntax/loc stx (define-honu-syntax name (lambda (stx ctx) @@ -452,7 +454,7 @@ (lambda () result))) (let ([result (honu-unparsed-begin code ...)]) (lambda () result)) - #'(rrest (... ...)))]))))) + #'(rrest (... ...)))])))))) #; (with-syntax ([parsed (let-values ([(out rest*) (parse-block-one/2 #'(code ...) diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index 06a1554f42..ea93125202 100644 --- a/collects/honu/private/more.ss +++ b/collects/honu/private/more.ss @@ -4,13 +4,16 @@ "literals.ss" syntax/parse mzlib/trace + "syntax.ss" (for-syntax syntax/parse syntax/stx racket/list + "syntax.ss" (only-in racket (... scheme-ellipses)) "literals.ss") (for-template "honu-typed-scheme.ss" "literals.ss" + "syntax.ss" (only-in racket ...) )) @@ -25,6 +28,21 @@ (define (replace-commas stuff) (printf "Replace commas with: ~a\n" (syntax->datum stuff)) (syntax-parse stuff #:literals (ellipses-comma) + #; + [((ellipses-comma (z ...)) thing blah ...) + (define (maybe-apply-raw stx) + (syntax-parse stuff #:literals (ellipses-comma) + [((ellipses-comma x) . rest) + (if (raw-scheme? #'x) + (apply-scheme-syntax stx) + stx)])) + (printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...))) + (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))]) + (datum->syntax stuff (cons (maybe-apply-raw #'(z ...)) (cons #'honu-comma #'(rest ...))) + stuff + stuff) + #; + #'(z honu-comma rest ...))] [((ellipses-comma z) thing blah ...) #; (printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...))) @@ -32,16 +50,40 @@ #; (combine-syntax stuff #'z #'honu-comma #'(rest ...)) (datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...))) + stuff stuff) #; #'(z honu-comma rest ...))] [(front (ellipses-comma z) thing more ...) + (define (maybe-apply-raw stx) + (syntax-parse stuff #:literals (ellipses-comma) + [(front (ellipses-comma x) . rest) + (if (raw-scheme? #'x) + (apply-scheme-syntax stx) + stx)])) + (with-syntax ([front* (replace-commas #'front)] + [(rest* ...) (replace-commas #'(thing more ...))]) + (datum->syntax stuff (cons #'front* (cons #'z (cons #'honu-comma #'(rest* ...)))) + stuff + stuff))] + #; + [(front (ellipses-comma (z ...)) thing more ...) + (define (maybe-apply-raw stx) + (syntax-parse stuff #:literals (ellipses-comma) + [(front (ellipses-comma x) . rest) + (if (raw-scheme? #'x) + (apply-scheme-syntax stx) + stx)])) (with-syntax ([front* (replace-commas #'front)] [(rest* ...) (replace-commas #'(thing more ...))]) (datum->syntax stuff (cons #'front* - (cons #'z #'(rest* ...))) + (cons (maybe-apply-raw (datum->syntax stuff #'(z ...) stuff)) + (cons #'honu-comma #'(rest* ...)))) + stuff stuff))] - [((ellipses-comma z)) (datum->syntax stuff #'(z) stuff)] + #; + [((ellipses-comma (z ...))) (datum->syntax stuff #'(z ...) stuff stuff)] + [((ellipses-comma z)) (datum->syntax stuff #'(z) stuff stuff)] [(z rest ...) (with-syntax ([z* (replace-commas #'z)] [(rest* ...) (replace-commas #'(rest ...))]) @@ -49,12 +91,12 @@ (combine-syntax stuff #'z #'(rest* ...)) (datum->syntax stuff (cons #'z* #'(rest* ...)) - stuff) + stuff stuff) #; #'(z* rest* ...))] [else stuff])) -(trace replace-commas) +;; (trace replace-commas) (define-syntax (fix-template stuff) (define (fix stuff) @@ -76,7 +118,7 @@ [(rest* ...) (fix #'(rest ...))]) (datum->syntax stuff (cons #'one* #'(rest* ...)) - stuff) + stuff stuff) #; #'(one* rest* ...))] [else stuff])) @@ -87,16 +129,24 @@ [(rest* ...) (replace #'(rest ...))]) (datum->syntax stuff (cons - (cons #'ellipses-comma (cons #'a* '())) + (cons #'ellipses-comma (cons #'a* '()) + #; + (if (stx-pair? #'a*) + #'a* + (cons #'a* '()))) (cons #'(... ...) #'(rest* ...))) - stuff) + stuff stuff) #; #'((ellipses-comma a*) (... ...) rest* ...))] [(z rest ...) (with-syntax ([z* (replace #'z)] [(rest* ...) (replace #'(rest ...))]) + (datum->syntax stuff + (cons #'z* #'(rest* ...)) + stuff stuff) + #; #'(z* rest* ...))] [else stuff])) @@ -106,7 +156,7 @@ (let ([replaced (replace #'blah)]) (printf "Replaced ~a\n" (syntax->datum replaced)) (with-syntax ([out2 replaced]) - (let ([x #'(replace-commas #'out2)]) + (let ([x #'(apply-scheme-syntax (replace-commas #'out2))]) (printf "Final syntax ~a\n" (syntax->datum x)) x)))] #; @@ -144,6 +194,12 @@ #'(fix-template (honu-unparsed-begin expr ...)) + #; + #'(fix-template (expr ...)) + + #; + (apply-scheme-syntax #'(fix-template (expr ...))) + #; (let ([x #'(fix-template (honu-unparsed-begin expr ...))]) (printf "Final syntax ~a\n" (syntax->datum x)) diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 472c73a939..57405cb447 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -21,6 +21,7 @@ (provide (all-defined-out)) +#; (begin-for-syntax (current-failure-handler (lambda (_ f) @@ -150,13 +151,22 @@ (printf "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...))) #'(e.x arg.result ...))] + [pattern (~seq (~var e honu-identifier) (#%parens rest ...)) #:with call #f + #:when (begin + (printf "Trying a call on ~a and ~a\n" #'e #'(rest ...)) + #f)] + [pattern (~seq (~var e honu-identifier #; (honu-expr context)) + (~var d1 (debug-here (format "call 1 ~a\n" #'e))) (x - ;; #%parens + (~var d2 (debug-here (format "call 2 ~a\n" #'x))) + ;;#%parens (~seq (~var arg (ternary context)) - (~optional honu-comma)) ...)) + (~var d3 (debug-here (format "call 3 ~a\n" #'arg))) + (~optional honu-comma)) + ...)) #:with call (begin (printf "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...))) @@ -167,12 +177,23 @@ (define-splicing-syntax-class (expression-last context) #:literals (#%parens) - [pattern (~seq raw:raw-scheme-syntax) #:with result #'raw] + + #; + [pattern (~seq a 1 2 3 b 4 5 6)] + + [pattern (~seq x) #:with result #f #:when (begin (printf "Expression last ~a. Raw? ~a\n" #'x (raw-scheme? #'x)) #f)] + + [pattern (~seq raw:raw-scheme-syntax) #:with result #'raw.x + #; + (begin (printf "raw syntax ~a\n" #'raw) + (if (stx-pair? #'raw) + (stx-car #'raw) + #'raw))] + [pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result] - #; [pattern (~seq (~var e (honu-transformer context))) #:with result #'e.result] [pattern (~seq (~var call (call context))) #:with result #'call.call] - [pattern (~seq x:number) #:with result #'x] + [pattern (~seq x:number) #:with result (begin (printf "got a number ~a\n" #'x) #'x)] [pattern (~seq x:str) #:with result #'x] [pattern (~seq x:honu-identifier) #:with result #'x.x] #; @@ -189,12 +210,21 @@ (pattern (~seq (~var op operator-class) (~var right (next context)) - (~var new-right (do-rest context ((attribute op.func) left #'right.result)))) - #:with result (apply-scheme-syntax (attribute new-right.result))) - (pattern (~seq) #:with result left)) + (~var new-right (do-rest context ((attribute op.func) left (attribute right.result))))) + #:with result + (begin + (printf "Left was ~a\n" left) + (attribute new-right.result)) + + #; + (apply-scheme-syntax (attribute new-right.result))) + + (pattern (~seq) #:with result (begin #;(printf "Left is still ~a\n" left) + left))) + (define-splicing-syntax-class (name context) - (pattern (~seq (~var left (next context)) - (~var rest (do-rest context #'left.result))) + (pattern (~seq (~var left2 (next context)) + (~var rest (do-rest context (attribute left2.result)))) #:with result (attribute rest.result))) #; @@ -283,21 +313,32 @@ (define-splicing-syntax-class (ternary context) #:literals (honu-? honu-:) [pattern (~seq (~var condition (expression-1 context)) + (~var x1 (debug-here (format "ternary 1 ~a\n" #'condition.result))) (~optional (~seq honu-? (~var on-true (ternary context)) - honu-: (~var on-false (ternary context))))) + honu-: (~var on-false (ternary context)))) + (~var x2 (debug-here "ternary 2")) + ) #:with result (cond [(attribute on-true) #'(if condition.result on-true.result on-false.result)] [else #'condition.result])]) +(define-splicing-syntax-class (debug-here d) + [pattern (~seq) #:when (begin + (printf "Debug parse I got here ~a\n" d) + #t)]) + (define-syntax-class (expression-top context) #:literals (semicolon) - [pattern ((~var e (ternary context)) semicolon . rest) + [pattern ((~var e (ternary context)) + (~var x1 (debug-here (format "expression top 1 ~a\n" #'e))) + semicolon + (~var x2 (debug-here "2")) + . rest) #:with result #'e.result]) - -(define-syntax-class raw-scheme-syntax - [pattern x #:when (syntax-property #'x honu-scheme-syntax)]) +(define-splicing-syntax-class raw-scheme-syntax + [pattern (~seq x) #:when (raw-scheme? #'x)]) (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) (make-struct-type-property 'honu-transformer)) @@ -385,7 +426,7 @@ stx])) (define-splicing-syntax-class expression - [pattern (~seq (~var x (expression-1 the-expression-context)))]) + [pattern (~seq (~var x (expression-1 the-expression-context))) #:with result (apply-scheme-syntax #'x.result)]) (define-splicing-syntax-class expression-comma #:literals (honu-comma) @@ -424,12 +465,15 @@ #; (let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))]) (printf "debug parse for ~a is ~a and ~a\n" 'SQL_create_insert a b)) + #; (let-values ([(a b) (debug-parse stx ((~seq (~var x (expression-top context)))))]) (printf "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b)) ;; (printf "~a\n" (syntax-class-parse function stx)) (syntax-parse stx + #; [(raw:raw-scheme-syntax . rest) (values #'raw #'rest)] + #; [function:function (values #'function.result #'function.rest)] [(~var expr (expression-top context)) (values #'expr.result #'expr.rest)] #; @@ -492,7 +536,11 @@ (values out rest2))] [else (values fixed rest)])) ))] - [else (parse-one stx context)])) + [else (parse-one stx context)] + #; + [else (let-values ([(a b) (parse-one stx context)]) + (values (apply-scheme-syntax a) b))] + )) (define operator? (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) diff --git a/collects/honu/private/syntax.ss b/collects/honu/private/syntax.ss index 8540ad375a..e99d03c3a2 100644 --- a/collects/honu/private/syntax.ss +++ b/collects/honu/private/syntax.ss @@ -17,11 +17,17 @@ (define-syntax honu-unparsed-expr (lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this"))) +(define honu-scheme-syntax 'honu-scheme-syntax) + +#; (define honu-scheme-syntax (gensym)) (define-syntax-rule (scheme-syntax stx) (syntax-property (syntax stx) honu-scheme-syntax #t)) +(define (raw-scheme? stx) + (syntax-property stx honu-scheme-syntax)) + (define (apply-scheme-syntax stx) (syntax-property stx honu-scheme-syntax #t))