diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index a9dfdf2f44..06a1554f42 100644 --- a/collects/honu/private/more.ss +++ b/collects/honu/private/more.ss @@ -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)] diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index f6a40da7c9..472c73a939 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -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) diff --git a/collects/honu/private/syntax.ss b/collects/honu/private/syntax.ss index cacb69ddcb..8540ad375a 100644 --- a/collects/honu/private/syntax.ss +++ b/collects/honu/private/syntax.ss @@ -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 ()