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

attach original syntax properties during expansion. add debug syntax

Browse Source 
classes.
This commit is contained in:
Jon Rafkind 2010-05-21 15:35:51 -06:00
parent d90235efbc
commit 0ec71da614
5 changed files with 157 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/honu/private/honu-typed-scheme.rkt
View File

@ -11,6 +11,7 @@
"contexts.ss" "contexts.ss"
"util.ss" "util.ss"
"ops.ss" "ops.ss"
"syntax.ss"
"parse.ss" "parse.ss"
) )
(for-template scheme/base) (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) (lambda (stx ctx)
(syntax-parse stx #:literals (semicolon) (syntax-parse stx #:literals (semicolon)
[(_ word:identifier ... semicolon . rest) [(_ 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"))) (define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this")))
...)) ...)))
#'rest)]))) #'rest)])))
(define-honu-syntax honu-if (define-honu-syntax honu-if
@ -511,8 +513,20 @@ if (foo){
(if (stx-null? #'(rest ...)) (if (stx-null? #'(rest ...))
(syntax/loc stx (syntax/loc stx
code) code)
#;
(if (raw-scheme? #'code)
(syntax/loc stx (syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))))))] code)
(with-syntax ([(code* ...) #'code])
(syntax/loc stx (honu-unparsed-begin code* ...))))
(syntax/loc stx
(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) (let-values ([(code rest) (parse-block-one the-top-block-context
#'body #'body

6
collects/honu/private/macro.rkt
View File

@ -11,6 +11,7 @@
(for-syntax "debug.ss" (for-syntax "debug.ss"
"contexts.ss" "contexts.ss"
"parse.ss" "parse.ss"
"syntax.ss"
"honu-typed-scheme.ss" "honu-typed-scheme.ss"
scheme/base scheme/base
syntax/parse syntax/parse
@ -439,7 +440,8 @@
(let ([result (honu-unparsed-begin code ...)]) (let ([result (honu-unparsed-begin code ...)])
(lambda () result)) (lambda () result))
#'(rrest (... ...)))]))) #'(rrest (... ...)))])))
(printf "Original pattern ~a" (syntax->datum #'(fixed ... rrest (... ...)))) (printf "Original pattern ~a\n" (syntax->datum #'(fixed ... rrest (... ...))))
(apply-scheme-syntax
(syntax/loc stx (syntax/loc stx
(define-honu-syntax name (define-honu-syntax name
(lambda (stx ctx) (lambda (stx ctx)
@ -452,7 +454,7 @@
(lambda () result))) (lambda () result)))
(let ([result (honu-unparsed-begin code ...)]) (let ([result (honu-unparsed-begin code ...)])
(lambda () result)) (lambda () result))
#'(rrest (... ...)))]))))) #'(rrest (... ...)))]))))))
#; #;
(with-syntax ([parsed (let-values ([(out rest*) (with-syntax ([parsed (let-values ([(out rest*)
(parse-block-one/2 #'(code ...) (parse-block-one/2 #'(code ...)

72
collects/honu/private/more.ss
View File

@ -4,13 +4,16 @@
"literals.ss" "literals.ss"
syntax/parse syntax/parse
mzlib/trace mzlib/trace
"syntax.ss"
(for-syntax syntax/parse (for-syntax syntax/parse
syntax/stx syntax/stx
racket/list racket/list
"syntax.ss"
(only-in racket (... scheme-ellipses)) (only-in racket (... scheme-ellipses))
"literals.ss") "literals.ss")
(for-template "honu-typed-scheme.ss" (for-template "honu-typed-scheme.ss"
"literals.ss" "literals.ss"
"syntax.ss"
(only-in racket ...) (only-in racket ...)
)) ))
@ -25,6 +28,21 @@
(define (replace-commas stuff) (define (replace-commas stuff)
(printf "Replace commas with: ~a\n" (syntax->datum stuff)) (printf "Replace commas with: ~a\n" (syntax->datum stuff))
(syntax-parse stuff #:literals (ellipses-comma) (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 ...) [((ellipses-comma z) thing blah ...)
#; #;
(printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(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 ...)) (combine-syntax stuff #'z #'honu-comma #'(rest ...))
(datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...))) (datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...)))
stuff
stuff) stuff)
#; #;
#'(z honu-comma rest ...))] #'(z honu-comma rest ...))]
[(front (ellipses-comma z) thing more ...) [(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)] (with-syntax ([front* (replace-commas #'front)]
[(rest* ...) (replace-commas #'(thing more ...))]) [(rest* ...) (replace-commas #'(thing more ...))])
(datum->syntax stuff (cons #'front* (datum->syntax stuff (cons #'front*
(cons #'z #'(rest* ...))) (cons (maybe-apply-raw (datum->syntax stuff #'(z ...) stuff))
(cons #'honu-comma #'(rest* ...))))
stuff
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 ...) [(z rest ...)
(with-syntax ([z* (replace-commas #'z)] (with-syntax ([z* (replace-commas #'z)]
[(rest* ...) (replace-commas #'(rest ...))]) [(rest* ...) (replace-commas #'(rest ...))])
@ -49,12 +91,12 @@
(combine-syntax stuff #'z #'(rest* ...)) (combine-syntax stuff #'z #'(rest* ...))
(datum->syntax stuff (datum->syntax stuff
(cons #'z* #'(rest* ...)) (cons #'z* #'(rest* ...))
stuff) stuff stuff)
#; #;
#'(z* rest* ...))] #'(z* rest* ...))]
[else stuff])) [else stuff]))
(trace replace-commas) ;; (trace replace-commas)
(define-syntax (fix-template stuff) (define-syntax (fix-template stuff)
(define (fix stuff) (define (fix stuff)
@ -76,7 +118,7 @@
[(rest* ...) (fix #'(rest ...))]) [(rest* ...) (fix #'(rest ...))])
(datum->syntax stuff (cons #'one* (datum->syntax stuff (cons #'one*
#'(rest* ...)) #'(rest* ...))
stuff) stuff stuff)
#; #;
#'(one* rest* ...))] #'(one* rest* ...))]
[else stuff])) [else stuff]))
@ -87,16 +129,24 @@
[(rest* ...) (replace #'(rest ...))]) [(rest* ...) (replace #'(rest ...))])
(datum->syntax stuff (datum->syntax stuff
(cons (cons
(cons #'ellipses-comma (cons #'a* '())) (cons #'ellipses-comma (cons #'a* '())
#;
(if (stx-pair? #'a*)
#'a*
(cons #'a* '())))
(cons (cons
#'(... ...) #'(... ...)
#'(rest* ...))) #'(rest* ...)))
stuff) stuff stuff)
#; #;
#'((ellipses-comma a*) (... ...) rest* ...))] #'((ellipses-comma a*) (... ...) rest* ...))]
[(z rest ...) [(z rest ...)
(with-syntax ([z* (replace #'z)] (with-syntax ([z* (replace #'z)]
[(rest* ...) (replace #'(rest ...))]) [(rest* ...) (replace #'(rest ...))])
(datum->syntax stuff
(cons #'z* #'(rest* ...))
stuff stuff)
#;
#'(z* rest* ...))] #'(z* rest* ...))]
[else stuff])) [else stuff]))
@ -106,7 +156,7 @@
(let ([replaced (replace #'blah)]) (let ([replaced (replace #'blah)])
(printf "Replaced ~a\n" (syntax->datum replaced)) (printf "Replaced ~a\n" (syntax->datum replaced))
(with-syntax ([out2 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)) (printf "Final syntax ~a\n" (syntax->datum x))
x)))] x)))]
#; #;
@ -144,6 +194,12 @@
#'(fix-template (honu-unparsed-begin expr ...)) #'(fix-template (honu-unparsed-begin expr ...))
#;
#'(fix-template (expr ...))
#;
(apply-scheme-syntax #'(fix-template (expr ...)))
#; #;
(let ([x #'(fix-template (honu-unparsed-begin expr ...))]) (let ([x #'(fix-template (honu-unparsed-begin expr ...))])
(printf "Final syntax ~a\n" (syntax->datum x)) (printf "Final syntax ~a\n" (syntax->datum x))

80
collects/honu/private/parse.rkt
View File

@ -21,6 +21,7 @@
(provide (all-defined-out)) (provide (all-defined-out))
#;
(begin-for-syntax (begin-for-syntax
(current-failure-handler (current-failure-handler
(lambda (_ f) (lambda (_ f)
@ -150,13 +151,22 @@
(printf "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...))) (printf "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...)))
#'(e.x 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 [pattern (~seq (~var e honu-identifier
#; #;
(honu-expr context)) (honu-expr context))
(~var d1 (debug-here (format "call 1 ~a\n" #'e)))
(x (x
(~var d2 (debug-here (format "call 2 ~a\n" #'x)))
;;#%parens ;;#%parens
(~seq (~var arg (ternary context)) (~seq (~var arg (ternary context))
(~optional honu-comma)) ...)) (~var d3 (debug-here (format "call 3 ~a\n" #'arg)))
(~optional honu-comma))
...))
#:with call #:with call
(begin (begin
(printf "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...))) (printf "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...)))
@ -167,12 +177,23 @@
(define-splicing-syntax-class (expression-last context) (define-splicing-syntax-class (expression-last context)
#:literals (#%parens) #:literals (#%parens)
[pattern (~seq raw:raw-scheme-syntax) #:with result #'raw]
[pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result]
#; #;
[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 e (honu-transformer context))) #:with result #'e.result]
[pattern (~seq (~var call (call context))) #:with result #'call.call] [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:str) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x.x] [pattern (~seq x:honu-identifier) #:with result #'x.x]
#; #;
@ -189,12 +210,21 @@
(pattern (~seq (~var op operator-class) (pattern (~seq (~var op operator-class)
(~var right (next context)) (~var right (next context))
(~var new-right (do-rest context ((attribute op.func) left #'right.result)))) (~var new-right (do-rest context ((attribute op.func) left (attribute right.result)))))
#:with result (apply-scheme-syntax (attribute new-right.result))) #:with result
(pattern (~seq) #:with result left)) (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) (define-splicing-syntax-class (name context)
(pattern (~seq (~var left (next context)) (pattern (~seq (~var left2 (next context))
(~var rest (do-rest context #'left.result))) (~var rest (do-rest context (attribute left2.result))))
#:with result #:with result
(attribute rest.result))) (attribute rest.result)))
#; #;
@ -283,21 +313,32 @@
(define-splicing-syntax-class (ternary context) (define-splicing-syntax-class (ternary context)
#:literals (honu-? honu-:) #:literals (honu-? honu-:)
[pattern (~seq (~var condition (expression-1 context)) [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)) (~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 #:with result
(cond [(attribute on-true) (cond [(attribute on-true)
#'(if condition.result on-true.result on-false.result)] #'(if condition.result on-true.result on-false.result)]
[else #'condition.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) (define-syntax-class (expression-top context)
#:literals (semicolon) #: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]) #:with result #'e.result])
(define-splicing-syntax-class raw-scheme-syntax
(define-syntax-class raw-scheme-syntax [pattern (~seq x) #:when (raw-scheme? #'x)])
[pattern x #:when (syntax-property #'x honu-scheme-syntax)])
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
(make-struct-type-property 'honu-transformer)) (make-struct-type-property 'honu-transformer))
@ -385,7 +426,7 @@
stx])) stx]))
(define-splicing-syntax-class expression (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 (define-splicing-syntax-class expression-comma
#:literals (honu-comma) #:literals (honu-comma)
@ -424,12 +465,15 @@
#; #;
(let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))]) (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)) (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)))))]) (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 "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b))
;; (printf "~a\n" (syntax-class-parse function stx)) ;; (printf "~a\n" (syntax-class-parse function stx))
(syntax-parse stx (syntax-parse stx
#;
[(raw:raw-scheme-syntax . rest) (values #'raw #'rest)] [(raw:raw-scheme-syntax . rest) (values #'raw #'rest)]
#;
[function:function (values #'function.result #'function.rest)] [function:function (values #'function.result #'function.rest)]
[(~var expr (expression-top context)) (values #'expr.result #'expr.rest)] [(~var expr (expression-top context)) (values #'expr.result #'expr.rest)]
#; #;
@ -492,7 +536,11 @@
(values out rest2))] (values out rest2))]
[else (values fixed rest)])) [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? (define operator?
(let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])

6
collects/honu/private/syntax.ss
View File

@ -17,11 +17,17 @@
(define-syntax honu-unparsed-expr (lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this"))) (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 honu-scheme-syntax (gensym))
(define-syntax-rule (scheme-syntax stx) (define-syntax-rule (scheme-syntax stx)
(syntax-property (syntax stx) honu-scheme-syntax #t)) (syntax-property (syntax stx) honu-scheme-syntax #t))
(define (raw-scheme? stx)
(syntax-property stx honu-scheme-syntax))
(define (apply-scheme-syntax stx) (define (apply-scheme-syntax stx)
(syntax-property stx honu-scheme-syntax #t)) (syntax-property stx honu-scheme-syntax #t))