From 86e7b98d65e4d1a95fdb9d95d68a4026bb3f32b8 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Mon, 2 Aug 2010 12:13:26 -0600 Subject: [PATCH] fix condition. patterns can take literals --- collects/honu/core/main.rkt | 7 ++--- .../honu/core/private/honu-typed-scheme.rkt | 11 ++++++- collects/honu/core/private/literals.rkt | 5 +++- collects/honu/core/private/macro.rkt | 30 ++++++++++++------- collects/honu/core/private/parse.rkt | 13 ++++++-- collects/honu/main.rkt | 9 ------ collects/honu/private/common.honu | 25 +++++++++------- 7 files changed, 61 insertions(+), 39 deletions(-) diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index a960065c2f..7c5d4e150b 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -39,8 +39,6 @@ (define-for-syntax (syntax-to-string stx) (format "original '~a' - ~a" (syntax->datum stx) (to-honu-string stx))) -(define (cheetos1) 5) - (define-syntax (honu-struct stx) (syntax-parse stx [(_ name (my-field ...)) @@ -67,20 +65,20 @@ (honu-<= <=) (honu-== ==) (honu-= =) + (honu-literal literals) (honu-!= !=) (honu-? ?) (honu-: :) (honu-and and) (honu-comma |,|) (honu-. |.|) + (expression-comma expression_comma) ) #; (rename-out [honu-print print]) (for-syntax (rename-out [syntax-to-string syntax_to_string])) - (for-syntax cheetos) - cheetos1 #%top @@ -167,6 +165,7 @@ (honu-identifier identifier123) (honu-require require) (honu-for-syntax forSyntax) + (honu-for-template forTemplate) (honu-syntax syntax) (honu-pattern pattern) (honu-keywords keywords) diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index e297c44550..bbe8933ac3 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -389,6 +389,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (define-syntax-class expr [pattern e]) (define-syntax-class paren-expr + #:literals (#%parens) [pattern (#%parens expr:expression) #:with result #'expr.result]) (define-syntax-class block [pattern (#%braces statement ...) @@ -399,8 +400,9 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (syntax-parse stx #:literals (else) [(_ condition:paren-expr on-true:block else on-false:block . rest) + ;; (printf "Condition expr is ~a\n" #'condition.expr) ;; (printf "used if with else\n") - (let ([result #'(if condition.expr on-true.line on-false.line)]) + (let ([result #'(if condition.result on-true.line on-false.line)]) (values (lambda () result) #'rest) @@ -548,10 +550,17 @@ if (foo){ #; (datum->syntax body (cons #'for-syntax (cons #'spec #'())) body body)]) + (define-syntax-class for-template-form + #:literals (#%parens honu-for-template) + [pattern (#%parens honu-for-template spec) + #:with result + (datum->syntax #'spec (cons #'for-template (cons #'spec #'())) + #'spec #'spec)]) (define-syntax-class normal-form [pattern x:str #:with result #'x]) (define-syntax-class form [pattern x:for-syntax-form #:with result #'x.result] + [pattern x:for-template-form #:with result #'x.result] [pattern x:normal-form #:with result #'x.result]) (syntax-parse body #:literals (semicolon) [(_ form:form ... semicolon . rest) diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt index cba1debcc1..e927dcdf4c 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -18,8 +18,11 @@ honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= honu-!= honu-== + honu-literal honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon honu-and - ellipses-comma ellipses-comma* ellipses-repeat honu-for-syntax) + ellipses-comma ellipses-comma* ellipses-repeat + honu-for-syntax + honu-for-template) (define-literal-set cruft (#%parens #%brackets #%braces semicolon)) diff --git a/collects/honu/core/private/macro.rkt b/collects/honu/core/private/macro.rkt index 92839c2e18..75ce186000 100644 --- a/collects/honu/core/private/macro.rkt +++ b/collects/honu/core/private/macro.rkt @@ -435,8 +435,12 @@ (define-honu-syntax honu-pattern (lambda (stx ctx) (syntax-parse stx #:literal-sets ([cruft #:at stx]) + #:literals (honu-literal) ;; #%parens #%brackets semicolon) - [(_ name (#%parens all-attributes:identifier ...) (#%brackets xpattern ...) + [(_ name + (~optional (~seq honu-literal (#%parens literals ...))) + (#%parens all-attributes:identifier ...) + (#%brackets xpattern ...) semicolon . rest) (define my-parens (datum->syntax #'name '#%parens #'name #'name)) (define (create-pattern stuff) @@ -444,15 +448,20 @@ (syntax/loc stuff (pattern (~seq fixed ...))))) (values (lambda () - (with-syntax ([final-pattern (create-pattern #'(xpattern ...))] - #; - [parens (datum->syntax stx '#%parens stx)] - [parens (datum->syntax #'name '#%parens #'name #'name)]) - (syntax/loc stx - (define-splicing-syntax-class name - #:literal-sets ([cruft #:at name]) - #:attributes (all-attributes ...) - final-pattern)))) + (if (attribute literals) + (with-syntax ([final-pattern (create-pattern #'(xpattern ...))]) + (syntax/loc stx + (define-splicing-syntax-class name + #:literal-sets ([cruft #:at name]) + #:literals (literals ...) + #:attributes (all-attributes ...) + final-pattern))) + (with-syntax ([final-pattern (create-pattern #'(xpattern ...))]) + (syntax/loc stx + (define-splicing-syntax-class name + #:literal-sets ([cruft #:at name]) + #:attributes (all-attributes ...) + final-pattern))))) #'rest)]))) (define foobar 0) @@ -529,6 +538,7 @@ result))) #'(rrest (... ...)))] ... + [else (raise-syntax-error 'name "bad syntax")] )))))) #; (with-syntax ([parsed (let-values ([(out rest*) diff --git a/collects/honu/core/private/parse.rkt b/collects/honu/core/private/parse.rkt index 18951ed569..7d4efa04a2 100644 --- a/collects/honu/core/private/parse.rkt +++ b/collects/honu/core/private/parse.rkt @@ -85,7 +85,7 @@ (printf "Transforming honu macro ~a\n" (stx-car stx)) (let-values ([(used rest) (transformer (introducer stx) context)]) - (printf "Result is ~a. Object position is ~a\n" used (syntax-object-position stx (introducer rest))) + (printf "Result is ~a. Object position is ~a out of expression ~a\n" used (syntax-object-position stx (introducer rest)) (syntax->datum stx)) (list (introducer rest) (syntax-object-position stx (introducer rest)) (introducer (used)))))] @@ -196,7 +196,7 @@ [pattern (~seq x:honu-identifier) #:with result #'x.x]) (define-splicing-syntax-class (expression-last context) - #:literals (#%parens) + #:literals (#%parens honu-:) #; [pattern (~seq a 1 2 3 b 4 5 6)] @@ -210,6 +210,9 @@ (stx-car #'raw) #'raw))] + [pattern (~seq (#%braces code:statement)) + #:with result #'(begin code.result)] + [pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result] [pattern (~seq (~var call (call context))) #:with result #'call.call] [pattern (~seq (~var e (honu-transformer @@ -219,6 +222,7 @@ #:with result #'e.result #:with rest #'e.rest] [pattern (~seq x:number) #:with result (begin (printf "got a number ~a\n" #'x) #'x)] + [pattern (~seq honu-: id:honu-identifier) #:with result #''id.result] [pattern (~seq x:str) #:with result #'x] [pattern (~seq x:honu-identifier) #:with result #'x.x] #; @@ -514,6 +518,7 @@ ) #:with result (apply-scheme-syntax (attribute x.result)) #:with rest #'x.rest] + #; [pattern ((~var f (debug-here "statement1")) (~var x (expression-top the-top-block-context))) @@ -553,7 +558,9 @@ #; [pattern (~seq (~var expr honu-identifier) (~optional honu-comma))] - [pattern (~seq (~var expr (expression-1 the-expression-context)) (~optional honu-comma)) #:with result (apply-scheme-syntax #'expr.result)] + [pattern (~seq (~var expr (expression-1 the-expression-context)) + (~optional honu-comma)) + #:with result (apply-scheme-syntax #'expr.result)] #; [pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional honu-comma)) ...)]) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index ba03eb3e14..d62ee33274 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -14,12 +14,3 @@ "private/struct.honu" "private/function.honu" "private/common.honu") - -#| -(racket:require "core/main.rkt" - "private/struct.honu" - "private/function.honu") -(racket:provide [all-from-out "core/main.rkt"]) -(racket:provide [all-from-out "private/struct.honu" - "private/function.honu"]) -|# diff --git a/collects/honu/private/common.honu b/collects/honu/private/common.honu index 4f4227616f..ada454d5e1 100644 --- a/collects/honu/private/common.honu +++ b/collects/honu/private/common.honu @@ -2,29 +2,22 @@ require (forSyntax "with.honu"); require (forSyntax "function.honu"); +require (forSyntax "patterns.honu"); +require "keywords.honu"; provide print; +provide then; macro print () { _ (value:expression); } { syntax(display(value_result); newline();); } -{ _ value:expression_comma ... ; } { syntax({display(value_result);} ...); } +{ _ value:expression_comma ... ; } { syntax({display(value_result);} ... newline()); } provide check_expect; provide expect; keywords expect; macro check_expect (expect) { _ check:expression expect expected:expression ; } { - function bar(g){ - g + 1 - } - function foo(){ - cheetos() - } - // withSyntax [check_raw bar(2)]{ withSyntax [check_raw syntax_to_string(syntax(check);)]{ - // withSyntax [check_raw syntax_to_string(1)]{ - // withSyntax [check_raw foo()]{ - // withSyntax [check_raw 1]{ syntax({checked = check_result; out = expected_result; if (checked != out){ @@ -33,3 +26,13 @@ macro check_expect (expect) { _ check:expression expect expected:expression ; } }}); }; } + +provide condition; +macro condition (){ _ clause:condition_clause rest ... ;} +{ syntax(if (clause_condition_result) { + clause_out_result + } else { + condition rest ... ; + } + ); } +{ _ ; } { syntax(1;); }