diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 06d14c6bff..36a13c9ab1 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -27,6 +27,7 @@ [honu-not not] [honu-not !] [honu-structure structure] [honu-structure struct] + [literal:colon :] [literal:honu-= =] [literal:semicolon |;|] [literal:honu-comma |,|] diff --git a/collects/honu/core/private/literals.rkt b/collects/honu/core/private/literals.rkt index 966580b78d..4722fe5fdb 100644 --- a/collects/honu/core/private/literals.rkt +++ b/collects/honu/core/private/literals.rkt @@ -1,7 +1,8 @@ -#lang racket +#lang racket/base (provide (all-defined-out)) -(require syntax/parse) +(require syntax/parse + (for-syntax racket/base)) ;; macro for defining literal tokens that can be used in macros (define-syntax-rule (define-literal name ...) @@ -25,4 +26,4 @@ honu-for-syntax honu-for-template) -(define-literal-set cruft (#%parens #%brackets #%braces semicolon honu-= honu-comma)) +(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-= honu-comma)) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 83b0c883c8..dffb794867 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -97,6 +97,16 @@ (loop (cons #'name out) #'())] [() (reverse out)]))) +;; removes syntax that causes expression parsing to stop +(define (strip-stops code) + (define-syntax-class stopper #:literal-sets (cruft) + [pattern semicolon] + [pattern honu-comma] + [pattern colon]) + (syntax-parse code + [(x:stopper rest ...) (strip-stops #'(rest ...))] + [else code])) + (define (parse-comma-expression arguments) (if (null? (syntax->list arguments)) '() @@ -105,10 +115,18 @@ (if (empty-syntax? rest) (reverse used) (let-values ([(parsed unparsed) - (parse rest)]) + ;; FIXME: don't strip all stops, just comma + (parse (strip-stops rest))]) (loop (cons parsed used) unparsed)))))) +(define (stopper? what) + (define-literal-set check (honu-comma semicolon colon)) + (define is (and (identifier? what) + ((literal-set->predicate check) what))) + (debug "Comma? ~a ~a\n" what is) + is) + ;; 1 + 1 ;; ^ ;; left: identity @@ -197,24 +215,9 @@ 0 (lambda (x) x) (left final)))] - [(comma? #'head) + [(stopper? #'head) (values (left final) - #'(rest ...))] - [(semicolon? #'head) - (values (left final) - #'(rest ...)) - #; - (do-parse #'(rest ...) 0 - (lambda (stuff) - (with-syntax ([stuff stuff] - [current (left current)]) - #'(begin current stuff))) - #'(void)) - #; - (with-syntax ([so-far (left current)]) - #'(splicing-let-syntax ([more (lambda (stx) - (parse #'(rest ...)))]) - so-far (more)))] + stream)] [else (syntax-parse #'(head rest ...) #:literal-sets (cruft) [(function:identifier (#%parens args ...) (#%braces code ...) . rest) @@ -294,7 +297,7 @@ (let loop ([all '()] [code code]) (define-values (parsed unparsed) - (parse code)) + (parse (strip-stops code))) (debug "Parsed ~a unparsed ~a\n" (syntax->datum parsed) (syntax->datum unparsed)) (if (empty-syntax? unparsed) diff --git a/collects/honu/main.rkt b/collects/honu/main.rkt index e9459e5fb1..ada6a6f934 100644 --- a/collects/honu/main.rkt +++ b/collects/honu/main.rkt @@ -17,4 +17,5 @@ ;;"private/common.honu" ) -(provide sqr sqrt sin max) +(provide sqr sqrt sin max + (rename-out [honu-cond cond])) diff --git a/collects/honu/private/common.rkt b/collects/honu/private/common.rkt index 4b859d08d9..14908bcbbc 100644 --- a/collects/honu/private/common.rkt +++ b/collects/honu/private/common.rkt @@ -1,4 +1,22 @@ #lang racket/base +(require honu/core/private/macro2 + (for-syntax syntax/parse + racket/base + honu/core/private/literals + honu/core/private/parse2)) + (provide sqr) (define (sqr x) (* x x)) + +(provide honu-cond) +(define-honu-syntax honu-cond + (lambda (code context) + (syntax-parse code #:literal-sets (cruft) + [(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ... + semicolon . rest) + (values + #'(cond + [clause.result body.result] ...) + #'rest + #f)])))