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

dont parse raw scheme syntax. fix comma replacer

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-19 18:06:38 -06:00
parent 59db2491d0
commit d90235efbc
3 changed files with 74 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,6 +3,7 @@
(require "honu-typed-scheme.ss"
"literals.ss"
syntax/parse
mzlib/trace
(for-syntax syntax/parse
syntax/stx
racket/list
@ -15,17 +16,45 @@
(provide (all-defined-out))
(define (combine-syntax lexical . all)
(define consed (for/fold ([item all])
([out '()])
(cons item out)))
(datum->syntax lexical consed lexical))
(define (replace-commas stuff)
(syntax-parse stuff #:literals (ellipses-comma)
[((ellipses-comma z) thing blah ...)
(with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
#'(z honu-comma rest ...))]
[((ellipses-comma z)) #'z]
[(z rest ...)
(with-syntax ([z* (replace-commas #'z)]
[(rest* ...) (replace-commas #'(rest ...))])
#'(z* rest* ...))]
[else stuff]))
(printf "Replace commas with: ~a\n" (syntax->datum stuff))
(syntax-parse stuff #:literals (ellipses-comma)
[((ellipses-comma z) thing blah ...)
#;
(printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...)))
(with-syntax ([(rest ...) (replace-commas #'(thing blah ...))])
#;
(combine-syntax stuff #'z #'honu-comma #'(rest ...))
(datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...)))
stuff)
#;
#'(z honu-comma rest ...))]
[(front (ellipses-comma z) thing more ...)
(with-syntax ([front* (replace-commas #'front)]
[(rest* ...) (replace-commas #'(thing more ...))])
(datum->syntax stuff (cons #'front*
(cons #'z #'(rest* ...)))
stuff))]
[((ellipses-comma z)) (datum->syntax stuff #'(z) stuff)]
[(z rest ...)
(with-syntax ([z* (replace-commas #'z)]
[(rest* ...) (replace-commas #'(rest ...))])
#;
(combine-syntax stuff #'z #'(rest* ...))
(datum->syntax stuff
(cons #'z* #'(rest* ...))
stuff)
#;
#'(z* rest* ...))]
[else stuff]))
(trace replace-commas)
(define-syntax (fix-template stuff)
(define (fix stuff)
@ -56,6 +85,14 @@
[(a ellipses-comma rest ...)
(with-syntax ([a* (replace #'a)]
[(rest* ...) (replace #'(rest ...))])
(datum->syntax stuff
(cons
(cons #'ellipses-comma (cons #'a* '()))
(cons
#'(... ...)
#'(rest* ...)))
stuff)
#;
#'((ellipses-comma a*) (... ...) rest* ...))]
[(z rest ...)
(with-syntax ([z* (replace #'z)]

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

@ -147,8 +147,8 @@
(#%parens (~var arg (expression-1 context)) ...))
#:with call
(begin
(printf "Resulting call is ~a\n" (syntax->datum #'(e arg.result ...)))
#'(e arg.result ...))]
(printf "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...)))
#'(e.x arg.result ...))]
[pattern (~seq (~var e honu-identifier
#;
@ -159,21 +159,22 @@
(~optional honu-comma)) ...))
#:with call
(begin
(printf "Resulting call is ~a\n" (syntax->datum #'(e arg.result ...)))
#'(e arg.result ...))])
(printf "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...)))
#'(e.x arg.result ...))])
(define-splicing-syntax-class honu-identifier
[pattern (~seq x:identifier) #:when (not (free-identifier=? #'honu-comma #'x))])
(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 (~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:str) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x]
[pattern (~seq x:honu-identifier) #:with result #'x.x]
#;
[pattern (~seq (~var e (honu-expr context))) #:with result #'e.result]
)
@ -189,7 +190,7 @@
(~var right (next context))
(~var new-right (do-rest context ((attribute op.func) left #'right.result))))
#:with result (attribute new-right.result))
#:with result (apply-scheme-syntax (attribute new-right.result)))
(pattern (~seq) #:with result left))
(define-splicing-syntax-class (name context)
(pattern (~seq (~var left (next context))
@ -388,7 +389,22 @@
(define-splicing-syntax-class expression-comma
#:literals (honu-comma)
[pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional comma)) ...)])
#;
[pattern ;; ((~seq x) ...)
(x ...)
#:with (expr ...) (filter (lambda (n)
(not (free-identifier=? #'honu-comma n)))
(syntax->list #'(x ...)))]
#;
[pattern ((~seq (~var expr honu-identifier) (~optional honu-comma)) ...)]
#;
[pattern (~seq (~var expr honu-identifier) (~optional honu-comma))]
[pattern (~seq (~var expr (expression-1 the-expression-context)) (~optional honu-comma)) #:with result #'expr.result]
#;
[pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional honu-comma)) ...)])
(define (parse-an-expr stx)
(printf "Parse an expr ~a\n" (syntax->datum stx))
@ -419,7 +435,7 @@
#;
[(x:number . rest) (values #'x #'rest)]
))
(printf "Parsing ~a\n" stx)
(printf "Parsing ~a\n" (syntax->datum stx))
(cond
[(stx-null? stx) (values stx '())]
#;
@ -478,8 +494,6 @@
))]
[else (parse-one stx context)]))
(define operator?
(let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])
(lambda (stx)

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

@ -22,6 +22,9 @@
(define-syntax-rule (scheme-syntax stx)
(syntax-property (syntax stx) honu-scheme-syntax #t))
(define (apply-scheme-syntax stx)
(syntax-property stx honu-scheme-syntax #t))
#;
(define-syntax (scheme-syntax stx)
(syntax-case stx ()