diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 88a6e33928..0ba9590300 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -76,6 +76,7 @@ [literal:semicolon %semicolon] [literal:honu-comma %comma] [literal:honu-comma %comma] + [literal:honu-$ $] [literal:honu-<- <-] [literal:honu-in-lines inLines] [literal:#%brackets #%brackets] diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt index 3d5847f8dc..23b2f213f1 100644 --- a/collects/honu/core/private/compile.rkt +++ b/collects/honu/core/private/compile.rkt @@ -1,14 +1,20 @@ #lang racket/base (require syntax/parse + (for-syntax racket/base "debug.rkt" syntax/parse) "literals.rkt") +;; to get syntax as a literal +(require (for-template racket/base)) + (provide (all-defined-out)) (define (honu->racket forms) (define-literal-set literals (%racket)) (syntax-parse forms #:literal-sets (literals) + #:literals ([literal-syntax syntax]) [(%racket x) (honu->racket #'x)] + [(literal-syntax form) #'#'form] [(form ...) (datum->syntax forms (map honu->racket (syntax->list #'(form ...))) @@ -26,3 +32,31 @@ (syntax-parse code [(x:stopper rest ...) (strip-stops #'(rest ...))] [else code])) + +(define-syntax repeat$ (lambda (stx) (raise-syntax-error 'repeat$ "dont use this"))) + +(define-syntax (unexpand-honu-syntax stx) + (define (remove-repeats input) + (debug "Remove repeats from ~a\n" (syntax->datum input)) + (define-literal-set locals (repeat$)) + (syntax-parse input #:literal-sets (locals) + [(out ... (repeat$ stuff ...) rest ...) + (debug " Found a repeat\n") + (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))] + [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))]) + (remove-repeats #'(out* ... stuff ... rest* ...)))] + [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))]) + (datum->syntax input + #'(normal* ...) + input input))] + [x #'x] + [else (raise-syntax-error 'repeats "unhandled case" input)])) + + (syntax-case stx () + [(_ expr) + (begin + (debug "Expand honu syntax at phase ~a\n" (syntax-local-phase-level)) + (debug " Is ~a expanded ~a\n" (syntax->datum #'expr) (syntax->datum #'#'expr)) + (define removed (remove-repeats #'expr)) + (debug "Cleansed ~a\n" (syntax->datum removed)) + removed)])) diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index d6b9bfd2af..e618d501de 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -475,7 +475,10 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt ;; if parsed is #f then we don't want to expand to anything that will print ;; so use an empty form, begin, `parsed' could be #f becuase there was no expression ;; in the input such as parsing just ";". - (with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))] + (with-syntax ([parsed (if (not parsed) #'(begin) + parsed + #; + (honu->racket parsed))] [(unparsed ...) unparsed]) (debug "Final parsed syntax\n~a\n" (pretty-format (syntax->datum #'parsed))) (if (null? (syntax->datum #'(unparsed ...))) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index c03c06e7ac..36043efb6e 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -333,7 +333,9 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(var:honu-declaration . rest) - (define result #'(%racket (define-values (var.name ...) var.expression))) + (define result + (with-syntax ([var.expression (honu->racket #'var.expression)]) + #'(%racket (define-values (var.name ...) var.expression)))) (values result #'rest #t)]))) (provide (rename-out [honu-with-syntax withSyntax])) diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt index 5adca0a613..3d5e6c9599 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -31,6 +31,7 @@ honu-for-syntax honu-for-template honu-prefix + honu-$ ;; FIXME: in-lines should probably not be here honu-in-lines %racket) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index ec799ce440..63d67de5a4 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -8,6 +8,7 @@ "literals.rkt" "parse2.rkt" "debug.rkt" + "compile.rkt" racket/base) (for-meta 2 syntax/parse racket/base @@ -15,6 +16,7 @@ "compile.rkt") "literals.rkt" "syntax.rkt" + (for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt") #; (for-syntax "honu-typed-scheme.rkt") syntax/parse) @@ -155,14 +157,29 @@ ;; Do any honu-specific expansion here (define-honu-syntax honu-syntax (lambda (code context) + (define (compress-dollars stx) + (define-literal-set local-literals (honu-$)) + (syntax-parse stx #:literal-sets (local-literals) + [(honu-$ x ... honu-$ rest ...) + (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))]) + #'((repeat$ x ...) rest* ...))] + [(x rest ...) + (with-syntax ([x* (compress-dollars #'x)] + [(rest* ...) (compress-dollars #'(rest ...))]) + #'(x* rest* ...))] + [x #'x])) (syntax-parse code #:literal-sets (cruft) [(_ (#%parens stuff ...) . rest) (define context (stx-car #'(stuff ...))) + (define compressed (compress-dollars #'(stuff ...))) (values (with-syntax ([stuff* (datum->syntax context - (syntax->list #'(stuff ...)) + (syntax->list compressed) context context)]) - #'(%racket #'stuff*)) + ;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*)) + ;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*)) + (with-syntax ([(out ...) #'stuff*]) + #'(%racket #'(%racket (unexpand-honu-syntax (do-parse-rest-macro out ...)))))) #; #'(%racket-expression (parse-stuff stuff ...)) #'rest #f)]))) @@ -179,17 +196,7 @@ (provide honu-pattern) (define-honu-syntax honu-pattern (lambda (code context) - (define (bind-to-results pattern) - (with-syntax ([((pattern-variable.name pattern-variable.result) ...) - (find-pattern-variables pattern)]) - (with-syntax ([(each ...) - (for/list ([name (syntax->list #'(pattern-variable.name ...))] - [result (syntax->list #'(pattern-variable.result ...))]) - (with-syntax ([name name] - [result result]) - #'(#:with result result)))]) - #'(each ...)))) - (define (generate-pattern name literals original-pattern) + (define (generate-pattern name literals original-pattern maybe-out) (define variables (find-pattern-variables original-pattern)) (define use (generate-temporaries variables)) (define mapping (make-hash)) @@ -206,8 +213,10 @@ [(literal ...) literals] [(new-pattern ...) (convert-pattern original-pattern mapping)] [((withs ...) ...) withs] - #; - [((bindings ...) ...) (bind-to-results original-pattern)]) + [(result-with ...) (if maybe-out + (with-syntax ([(out ...) maybe-out]) + #'(#:with result (syntax out ...))) + #'())]) #'(%racket (begin-for-syntax (define-literal-set local-literals (literal ...)) (define-splicing-syntax-class name @@ -215,12 +224,15 @@ [local-literals #:at name]) [pattern (~seq new-pattern ...) withs ... ... - ; bindings ... ... + result-with ... ]))))) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens literal ...) (#%braces pattern ...) + (~optional (#%braces out ...)) . rest) - (values (generate-pattern #'name #'(literal ...) #'(pattern ...)) + (values (generate-pattern #'name #'(literal ...) + #'(pattern ...) + (attribute out)) #'rest #f)]))) diff --git a/collects/honu/core/private/parse-helper.rkt b/collects/honu/core/private/parse-helper.rkt new file mode 100644 index 0000000000..c6da1f23bc --- /dev/null +++ b/collects/honu/core/private/parse-helper.rkt @@ -0,0 +1,11 @@ +#lang racket/base + +(require (for-syntax racket/base + "parse2.rkt")) + +(provide (all-defined-out)) + +(define-syntax (do-parse-rest-macro stx) + (syntax-case stx () + [(_ stuff ...) + (do-parse-rest #'(stuff ...) #'do-parse-rest-macro)])) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 49e220aba6..689c99eb42 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -154,13 +154,16 @@ (debug 2 "Comma? ~a ~a\n" what is) is) +(provide do-parse-rest) (define (do-parse-rest stx parse-more) (syntax-parse stx - [(_ stuff ...) + [(stuff ...) (define-values (parsed unparsed) (parse (strip-stops #'(stuff ...)))) (debug "Parse more: ~a unparsed ~a\n" parsed unparsed) (define output (if parsed + parsed + #; (honu->racket parsed) #'(void))) (debug "Output ~a\n" output) @@ -169,20 +172,29 @@ [parse-more parse-more]) (if (null? (syntax->datum #'(unparsed-out ...))) #'output - #'(begin output (parse-more unparsed-out ...))))])) + #'(begin output (parse-more unparsed-out ...))))] + [() #'(begin)])) (define (do-parse-rest/local stx) (define name (gensym 'local-parser)) (define local-parser (with-syntax ([name name]) #'(define-syntax (name stx) - (do-parse-rest stx #'name)))) + (syntax-case stx () + [(_ stuff (... ...)) + (do-parse-rest #'(stuff (... ...)) #'name)])))) (with-syntax ([local local-parser] [parsed (do-parse-rest stx name)]) - #'(begin local parsed))) + (with-syntax ([(stx ...) stx] + [name name]) + #'(begin local (name stx ...))))) +#| +(provide do-parse-rest-macro) (define-syntax (do-parse-rest-macro stx) - (with-syntax ([stx stx]) - #'(do-parse-rest stx #'do-parse-rest-macro))) + (syntax-case stx () + [(_ stuff ...) + (do-parse-rest #'(stuff ...) #'do-parse-rest-macro)])) +|# (provide honu-body) (define-syntax-class honu-body @@ -259,7 +271,7 @@ precedence left current) (define re-parse (with-syntax ([(x ...) #'parsed]) - (do-parse-rest/local #'(nothing x ...)))) + (do-parse-rest/local #'(x ...)))) (debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse))) #; (define re-parse (let-values ([(re-parse re-unparse) @@ -287,7 +299,8 @@ [pattern x:str] [pattern x:number]) - (debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum stream) precedence left current) + (debug "parse ~a precedence ~a left ~a current ~a\n" + (syntax->datum stream) precedence left current) (define final (if current current #f)) (syntax-parse stream #:literal-sets (cruft) #; @@ -299,7 +312,7 @@ (debug "Native racket expression ~a\n" #'racket) (if current (values (left current) stream) - (values (left stream) #'())) + (values (left #'racket) #'())) #; (if current (values (left current) stream) @@ -325,7 +338,6 @@ [(honu-macro? #'head) (debug "Macro ~a\n" #'head) (do-macro #'head #'(rest ...) precedence left current stream)] - #; [(parsed-syntax? #'head) (debug "Parsed syntax ~a\n" #'head) (do-parse #'(rest ...) precedence left #'head)] diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index 1377f067ed..49e5b3a718 100644 --- a/collects/honu/core/read.rkt +++ b/collects/honu/core/read.rkt @@ -37,8 +37,8 @@ (:~ #\"))) (define-lex-abbrev string (:: #\" (:* string-character) #\")) (define-lex-abbrev operator (:or "+=" "-=" "*=" "/=" - "+" "!=" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<=" - ">=" "<-" "<" ">" "!" "::" ":=" "%")) + "+" "!=" "=>" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<=" + ">=" "<-" "<" ">" "!" "::" ":=" "%" "$")) (define-lex-abbrev block-comment (:: "/*" (complement (:: any-string "*/" any-string)) "*/")) diff --git a/collects/honu/private/common.rkt b/collects/honu/private/common.rkt index 517c1dea30..76edd1f342 100644 --- a/collects/honu/private/common.rkt +++ b/collects/honu/private/common.rkt @@ -5,6 +5,7 @@ (for-syntax syntax/parse racket/base honu/core/private/literals + honu/core/private/compile honu/core/private/parse2)) (provide sqr) @@ -22,8 +23,10 @@ [(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ... . rest) (values - #'(%racket (cond - [clause.result body.result] - ...)) + (with-syntax ([(clause.result ...) (map honu->racket (syntax->list #'(clause.result ...)))] + [(body.result ...) (map honu->racket (syntax->list #'(body.result ...)))]) + #'(%racket (cond + [clause.result body.result] + ...))) #'rest #t)]))) diff --git a/collects/tests/honu/match.honu b/collects/tests/honu/match.honu new file mode 100644 index 0000000000..6451953cdd --- /dev/null +++ b/collects/tests/honu/match.honu @@ -0,0 +1,31 @@ +#lang honu + +var => = 0 + +pattern match_pattern (){ [element:expression] } { [element] } + +pattern match_clause (| =>){ | pattern:match_pattern => out:expression , } + +macro mymatch(with){ + thing:expression with + clause:match_clause ... +} { + syntax( + cond + $ clause_pattern == thing: clause_out, $ ... + else: -2 + + /* + if (clause_pattern == thing){ + clause_out + } else { + -2 + } + */) +} + +mymatch [1] with +| [1] => 5, +| [2] => 6, + +// mymatch [1] with | [2] => 5