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"
"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
@ -511,8 +513,20 @@ if (foo){
(if (stx-null? #'(rest ...))
(syntax/loc stx
code)
#;
(if (raw-scheme? #'code)
(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

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

@ -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 ...)

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

@ -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))

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

@ -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 (#%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 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 "+-_=?:<>.!%^&*/~|")])

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 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))