diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index 784a192f3a..0022b01695 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -6,6 +6,7 @@ ;; "private/honu.ss" "private/parse.ss" "private/literals.ss" + "private/syntax.ss" "private/macro.ss") (define test-x-class @@ -30,6 +31,7 @@ ) #%datum #%braces + #%parens x true false @@ -37,11 +39,13 @@ display2 newline else + foobar2000 (rename-out (honu-if if) (honu-provide provide) (honu-macro-item macroItem) (honu-macro macro) + (honu-syntax syntax) )) #; diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index 6679875332..8d9f840e8f 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -269,8 +269,9 @@ (lambda (transformer) (let-values ([(code rest) (transformer body context)]) (combine-k code rest)))] - [else (call-values parse-one (extract-until body (list #'\; - )))])) + [else (call-values (extract-until body (list #'\; + )) + parse-one )])) #| (define-honu-macro (e ... * e ... \;)) @@ -295,13 +296,6 @@ x(2) ) -(define-syntax (define-honu-syntax stx) - (let-values ([(id rhs) (normalize-definition stx #'lambda #f)]) - (with-syntax ([id id] - [rhs rhs]) - #'(define-syntax id (make-honu-transformer rhs))))) - - #| Yes, check out head patterns and splicing syntax classes. @@ -320,6 +314,14 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt |# +(define-syntax (define-honu-syntax stx) + (let-values ([(id rhs) (normalize-definition stx #'lambda #f)]) + (with-syntax ([id id] + [rhs rhs]) + (syntax/loc stx + (define-syntax id (make-honu-transformer rhs)))))) + + (define-honu-syntax honu-provide (lambda (stx ctx) (syntax-parse stx @@ -328,6 +330,8 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (values #'(provide something) #'rest)]))) +;; (honu-syntax ...) + (define-honu-syntax honu-macro-item (lambda (stx ctx) (syntax-parse stx @@ -465,11 +469,18 @@ if (foo){ (define-syntax (honu-top stx) (raise-syntax-error #f "interactive use is not yet supported")) +(define-syntax (foobar2000 stx) + (printf "Called foobar2000 on ~a\n" (syntax->datum stx)) + (syntax-case stx () + [(_ x y ...) #'(printf "foobar2000 ~a\n" x)])) + (define (display2 x y) (printf "~a ~a" x y)) + + (define-syntax (honu-unparsed-begin stx) - ;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx)) + (printf "honu unparsed begin: ~a\n" (syntax->datum stx)) (syntax-case stx () [(_) #'(begin (void))] [(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body @@ -479,7 +490,8 @@ if (foo){ ;; (printf "Rest is ~a\n" (syntax->datum rest)) (with-syntax ([code code] [(rest ...) rest]) - #'(begin code (honu-unparsed-begin rest ...))))] + (syntax/loc stx + (begin code (honu-unparsed-begin rest ...)))))] #; [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context #'body @@ -490,9 +502,17 @@ if (foo){ [(rest ...) rest]) #'(begin code (honu-unparsed-begin rest ...))))])) +#; (define-syntax-rule (#%dynamic-honu-module-begin forms ...) #; (#%module-begin-typed-scheme ;; (require honu/private/typed-utils) (honu-unparsed-begin forms ...)) (#%plain-module-begin (honu-unparsed-begin forms ...))) + +(define-syntax (#%dynamic-honu-module-begin stx) + (syntax-case stx () + [(_ forms ...) + (begin + (printf "Module begin ~a\n" (syntax->datum #'(forms ...))) + #'(#%plain-module-begin (honu-unparsed-begin forms ...)))])) diff --git a/collects/honu/private/literals.rkt b/collects/honu/private/literals.rkt index d1fd426e24..6e40eaf7a1 100644 --- a/collects/honu/private/literals.rkt +++ b/collects/honu/private/literals.rkt @@ -16,4 +16,4 @@ honu-= honu-+= honu--= honu-*= honu-/= honu-%= honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= - honu-? honu-: honu-comma honu-. #%braces) + honu-? honu-: honu-comma honu-. #%braces #%parens) diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 23ebf955a9..3077e3d849 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -1,6 +1,9 @@ #lang scheme/base (require "honu-typed-scheme.ss" + "literals.ss" + "parse.ss" + "syntax.ss" (for-syntax "debug.ss" "contexts.ss" scheme/base @@ -11,6 +14,17 @@ (provide honu-macro) +(define-syntax (ensure-defined stx) + (syntax-case stx () + [(_ id ...) + (begin + (for-each (lambda (id) + (syntax-local-value id (lambda () (raise-syntax-error 'syntax-id "not defined" id)))) + (syntax->list #'(id ...))) + #'(void))])) + +(ensure-defined #%parens #%braces) + (define-for-syntax (extract-conventions pattern) (let loop ([out '()] [in pattern]) @@ -26,9 +40,6 @@ (loop out #'(rest1 rest ...))] [(foo) out]))) -(define-syntax (semicolon stx) - stx) - (define-for-syntax (extract-patterns pattern) (let loop ([out '()] [in pattern]) @@ -311,7 +322,8 @@ (syntax-case stx () [(_ x ...) (do-it #'(x ...))])) -;; (provide unpull) +(provide (for-syntax unpull)) + #; (define-honu-syntax unpull (lambda (stx ctx) @@ -355,6 +367,23 @@ 'pattern))] )))])) +#; +(define-syntax (honu-unparsed-expr stx) + (define (fix stx) + (printf "Fix ~a\n" (syntax->datum stx)) + (syntax-parse stx #:literals (honu-syntax #%parens) + [(honu-syntax (#%parens x ...) y ...) + (with-syntax ([(y* ...) (fix #'(y ...))]) + #'(x ... y* ...))] + [(z x ...) + (with-syntax ([z* (fix #'z)] + [(x* ...) (fix #'(x ...))]) + #'(z* x* ...))] + [else stx] + )) + (printf "unparsed expr ~a\n" stx) + (fix (stx-cdr stx))) + (define-syntax (test2 stx) (syntax-case stx () [(_ x ...) @@ -383,7 +412,8 @@ (syntax->list #'(pattern ...)))] ) (values - #'(define-honu-syntax name + (syntax/loc stx + (define-honu-syntax name (lambda (stx ctx) ;; (define-literal-set literals (honu-literal ...)) (syntax-parse stx @@ -397,16 +427,18 @@ (cond [(type-context? ctx) (X)] [(type-or-expression-context? ctx) (X)] - [(expression-context? ctx) #'(honu-unparsed-expr out (... ...))] + [(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))] [(expression-block-context? ctx) - #'(honu-unparsed-begin out (... ...))] + (syntax/loc stx + (honu-unparsed-begin out (... ...)))] [(block-context? ctx) - #'(honu-unparsed-begin out (... ...))] + (syntax/loc stx + (honu-unparsed-begin out (... ...)))] [(variable-definition-context? ctx) (X)] [(constant-definition-context? ctx) (X)] [(function-definition-context? ctx) (X)] [(prototype-context? ctx) (X)] - [else #'(honu-unparsed-expr out (... ...))]) + [else (syntax/loc stx (out (... ...)))]) #; #'(honu-unparsed-begin out (... ...)) #'rrest) @@ -422,9 +454,22 @@ #f obj 'obj #f ctx out (... ...) rrest) #; - #'rrest))]))) + #'rrest))])))) #'rest))] - [else (raise-syntax-error 'honu-macro "fail!")] + [(_ (m x ...) + (z y ...) + #; + (#%braces (#%braces name pattern ...)) + . rest) + (begin + (printf "Got literals ~a\n" #'(x ...)) + (printf "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m)) + (printf "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z)) + (printf "Rest is ~a\n" (syntax->datum #'rest)) + #; + (printf "Got name ~a pattern ~a\n" #'name #'(pattern ...)) + (raise-syntax-error 'honu-macro "f1" stx))] + [else (raise-syntax-error 'honu-macro "fail" stx)] ))) ;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...)) diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index d2db5ec1a7..583663c5b9 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -3,11 +3,14 @@ (require "contexts.ss" "util.ss" (for-template "literals.ss" - "language.ss") + "language.ss" + "syntax.ss") syntax/parse syntax/parse/experimental/splicing (for-syntax syntax/parse) scheme/splicing + (for-syntax syntax/define) + syntax/name syntax/stx (for-syntax "util.ss") (for-template scheme/base)) @@ -40,8 +43,14 @@ #:attrs (result) #:description "honu-expr" (lambda (stx fail) + (printf "Honu expr ~a\n" stx) (cond [(stx-null? stx) (fail)] + [(syntax-parse stx #:literals (honu-syntax) + [(honu-syntax expr ...) #'(expr ...)] + [else #f]) => (lambda (exprs) + (printf "Ignoring honu-syntax 1!\n") + (list exprs 0 #''()))] [(get-transformer stx) => (lambda (transformer) (printf "Transforming honu macro ~a\n" (car stx)) (let-values ([(used rest) @@ -55,8 +64,14 @@ #:attributes (result) #:description "honu-expr" (lambda (stx fail) + (printf "Honu expr ~a\n" stx) (cond [(stx-null? stx) (fail)] + [(syntax-parse stx #:literals (honu-syntax) + [(honu-syntax expr ...) #'(expr ...)] + [else #f]) => (lambda (exprs) + (printf "Ignoring honu-syntax 2!\n") + (list '() 0 exprs))] [(get-transformer stx) => (lambda (transformer) (printf "Transforming honu macro ~a\n" (car stx)) (let-values ([(used rest) @@ -96,6 +111,7 @@ (define-splicing-syntax-class (do-rest context left) (pattern (~seq (~var op operator-class) (~var right (next context)) + (~var new-right (do-rest context ((attribute op.func) left #'right.result)))) #:with result (attribute new-right.result)) (pattern (~seq) #:with result left)) @@ -203,6 +219,26 @@ #:with result #'e.result]) +(define (fix-output stx) + #| + (printf "Fix output ~a\n" stx) + (when (and (stx-pair? stx) (equal? 'syntax (syntax->datum (stx-car stx)))) + (printf "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax))) + |# + (syntax-parse stx #:literals (honu-syntax #%parens syntax) + [((honu-syntax (#%parens x ...) y ...) rest ...) + (with-syntax ([(y* ...) (fix-output #'(y ... rest ...))]) + (syntax/loc stx + (x ... y* ...)))] + ;; dont touch real syntax + [(syntax stuff ...) stx] + [(z x ...) + (with-syntax ([z* (fix-output #'z)] + [(x* ...) (fix-output #'(x ...))]) + (syntax/loc stx + (z* x* ...)))] + [else stx])) + (define (parse-block-one/2 stx context) (define (parse-one stx context) @@ -213,10 +249,30 @@ #; [(x:number . rest) (values #'x #'rest)] )) + (printf "Parsing ~a\n" stx) (cond [(stx-null? stx) (values stx '())] [(get-transformer stx) => (lambda (transformer) - (transformer stx context))] + (printf "Parse one: execute transformer ~a\n" transformer) + #; + (printf "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b))) + (call-values (transformer stx context) + (lambda (reparse rest) + (printf "Transformer gave us ~a\n" reparse) + #; + (values reparse rest) + #; + (values (fix-output reparse) rest) + #; + (printf "Macroized ~a and ~a\n" reparse rest) + (syntax-parse (fix-output reparse) #:literals (honu-unparsed-expr) + [(honu-unparsed-expr stuff ...) + (let-values ([(out rest2) + (with-syntax ([(more ...) rest]) + (parse-block-one/2 #'(stuff ... more ...) context))]) + (values out rest2))] + [else (values reparse rest)])) + ))] [else (parse-one stx context)])) (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) @@ -230,7 +286,6 @@ (and (positive? (string-length str)) (memq (string-ref str 0) sym-chars))))))) - (define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!) (make-struct-type 'honu-trans #f 1 0 #f (list (list prop:honu-transformer #t)) @@ -246,6 +301,8 @@ (make-honu-trans proc)) + + ;; returns a transformer or #f (define (get-transformer stx) ;; if its an identifier and bound to a transformer return it @@ -283,3 +340,14 @@ ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx)) (or (bound-transformer stx) (special-transformer stx))) + +#; +(define-honu-syntax honu-syntax + (lambda (stx ctx) + (syntax-case stx () + [(_ expr ...) + (begin + (printf "Honu syntax on ~a\n" #'(expr ...)) + (raise-syntax-error 'honu-syntax "should have been handled already") + #; + (parse-block-one/2 #'(expr ...) the-expression-context))]))) diff --git a/collects/honu/private/util.rkt b/collects/honu/private/util.rkt index 5120dd3cfa..d870fb1575 100644 --- a/collects/honu/private/util.rkt +++ b/collects/honu/private/util.rkt @@ -33,7 +33,7 @@ (loop (stx-cdr r) (cons (stx-car r) val-stxs))]))] [(r ids) (extract-until r ids #f)])) -(define-syntax-rule (call-values function values-producing) +(define-syntax-rule (call-values values-producing function) (call-with-values (lambda () values-producing) function)) ;; shortcut for treating arguments as syntax objects