diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index bbac97ed70..c53b999793 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -9,6 +9,7 @@ (for-syntax "private/literals.ss") (for-syntax "private/honu-typed-scheme.ss") (for-syntax "private/parse.ss") + (for-syntax syntax/parse) "private/literals.ss" "private/syntax.ss" "private/more.ss" @@ -23,6 +24,12 @@ (define x (new test-x-class [tuna 5])) +(define (sql1) #f) +(define (sql2) #f) +(define (sql3) #f) +(define (sql4) #f) +(define (sql5) #f) + (provide (rename-out (#%dynamic-honu-module-begin #%module-begin) (honu-top #%top) (semicolon \; @@ -37,7 +44,18 @@ (honu-comma |,|) (honu-. |.|) ) + + ;; sql nonsense + (rename-out + (sql1 SQL_create_insert) + (sql2 foo) + (sql3 cheese) + (sql4 monkeys) + (sql5 horse)) + ;; end sql + #%datum + #%top-interaction (for-syntax #%datum display with-syntax @@ -47,6 +65,7 @@ ... map syntax->list + identifier expression (rename-out (semicolon \; ) (parse-an-expr parse) @@ -76,6 +95,7 @@ (honu-macro-item macroItem) (honu-macro macro) (honu-syntax syntax) + (honu-keywords keywords) #; (honu-scheme scheme2) (scheme-syntax scheme:syntax) diff --git a/collects/honu/private/honu-typed-scheme.rkt b/collects/honu/private/honu-typed-scheme.rkt index 053b6f8b11..f63dbbc23a 100644 --- a/collects/honu/private/honu-typed-scheme.rkt +++ b/collects/honu/private/honu-typed-scheme.rkt @@ -348,6 +348,15 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt [else (raise-syntax-error 'scheme "need a semicolon probably" stx)] ))) +(define-honu-syntax honu-keywords + (lambda (stx ctx) + (syntax-parse stx #:literals (semicolon) + [(_ word:identifier ... semicolon . rest) + (values (lambda () #'(begin + (define-syntax word (lambda (xx) (raise-syntax-error 'word "dont use this"))) + ...)) + #'rest)]))) + (define-honu-syntax honu-if (lambda (stx ctx) (define (parse-complete-block stx) @@ -474,6 +483,7 @@ if (foo){ #'a)])) (define-syntax (honu-top stx) + (printf "Honu ~a\n" (syntax->datum stx)) (raise-syntax-error #f "interactive use is not yet supported")) (define-syntax (foobar2000 stx) @@ -492,9 +502,9 @@ if (foo){ (begin (printf "Body is ~a\n" #'body) (let-values ([(code rest) (parse-block-one/2 #'body - the-expression-context - #; - the-top-block-context)]) + the-expression-context + #; + the-top-block-context)]) ;; (printf "Rest is ~a\n" (syntax->datum rest)) (with-syntax ([code code] [(rest ...) rest]) diff --git a/collects/honu/private/macro.rkt b/collects/honu/private/macro.rkt index 21919c6a8b..32de54e6ae 100644 --- a/collects/honu/private/macro.rkt +++ b/collects/honu/private/macro.rkt @@ -4,6 +4,10 @@ "literals.ss" "parse.ss" "syntax.ss" + (for-meta -3 + (only-in "literals.ss" (#%parens literal-parens))) + #; + (for-template (only-in "literals.ss" (#%parens literal-parens))) (for-syntax "debug.ss" "contexts.ss" "parse.ss" @@ -67,10 +71,18 @@ (syntax-parse stx #:literals (honu-:) [(variable:id honu-: class:id rest ...) (with-syntax ([(rest* ...) (fix-template #'(rest ...))]) + (datum->syntax stx (cons #'(~var variable class) + #'(rest* ...)) + stx) + #; #'((~var variable class) rest* ...))] [(one rest ...) (with-syntax ([one* (fix-template #'one)] [(rest* ...) (fix-template #'(rest ...))]) + (datum->syntax stx (cons #'one* + #'(rest* ...)) + stx) + #; #'(one* rest* ...))] [else stx])) @@ -411,13 +423,32 @@ . rest) #:with result (list - (with-syntax ([(fixed ...) (fix-template #'(template ...))]) + (with-syntax ([(fixed ...) (fix-template #'(template ...))] + [your-parens (datum->syntax #'name '#%parens #'name)]) + + #'(define-honu-syntax name + (lambda (stx ctx) + (syntax-parse stx #:literals (your-parens literals ...) + [(fixed ... rrest (... ...)) + (values + #; + (with-syntax ([(real-out (... ...)) #'(code ...)]) + (let ([result (honu-unparsed-begin #'(real-out (... ...)))]) + (lambda () result))) + (let ([result (honu-unparsed-begin code ...)]) + (lambda () result)) + #'(rrest (... ...)))]))) + #; (syntax/loc stx (define-honu-syntax name (lambda (stx ctx) - (syntax-parse stx #:literals (literals ...) + (syntax-parse stx #:literals (your-parens literals ...) [(fixed ... rrest (... ...)) (values + #; + (with-syntax ([(real-out (... ...)) #'(code ...)]) + (let ([result (honu-unparsed-begin #'(real-out (... ...)))]) + (lambda () result))) (let ([result (honu-unparsed-begin code ...)]) (lambda () result)) #'(rrest (... ...)))]))))) diff --git a/collects/honu/private/more.ss b/collects/honu/private/more.ss index 41f9140e8b..2df52ad8fe 100644 --- a/collects/honu/private/more.ss +++ b/collects/honu/private/more.ss @@ -3,6 +3,7 @@ (require "honu-typed-scheme.ss" "literals.ss" (for-syntax syntax/parse + syntax/stx "literals.ss") (for-template "honu-typed-scheme.ss" "literals.ss" @@ -16,6 +17,19 @@ [(_ (#%parens expr ...) semicolon . rest) (values (lambda () - #'(honu-unparsed-begin expr ...)) + (define (show-pattern-variables what) + (cond + [(syntax-pattern-variable? what) (printf "~a is a pattern variable\n") what] + [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))] + [else (printf "~a is *not* a pattern variable\n" what)])) + + (printf "Original code is ~a\n" (syntax->datum #'(expr ...))) + (printf "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...)))) + (for-each show-pattern-variables (syntax->list #'(expr ...))) + ;; outer is relative phase 1, inner is relative phase 0 + #'#'(honu-unparsed-begin expr ...) + #; + (with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())]) + #'(honu-unparsed-begin out ...))) #'rest)]))) diff --git a/collects/honu/private/parse.rkt b/collects/honu/private/parse.rkt index 08f085a02f..1cdfc81a9a 100644 --- a/collects/honu/private/parse.rkt +++ b/collects/honu/private/parse.rkt @@ -19,12 +19,14 @@ (provide (all-defined-out)) (define-syntax-class block + #:literals (#%braces) [pattern (#%braces statement ...) #:with result (let-values ([(body rest) (parse-block-one/2 #'(statement ...) the-block-context)]) body)]) (define-syntax-class function - [pattern (type:id name:id (#%parens args ...) body:block . rest) + #:literals (#%parens) + [pattern (_ name:id (#%parens args ...) body:block . rest) #:with result #'(define (name args ...) body.result)]) @@ -133,7 +135,7 @@ [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:id) #:with result #'x] + [pattern (~seq x:identifier) #:with result #'x] #; [pattern (~seq (~var e (honu-expr context))) #:with result #'e.result] ) @@ -343,6 +345,9 @@ (printf " no change\n") stx])) +(define-splicing-syntax-class expression + [pattern (~seq (~var x (expression-1 the-expression-context)))]) + (define (parse-an-expr stx) (printf "Parse an expr ~a\n" (syntax->datum stx)) (syntax-parse (with-syntax ([s stx])