diff --git a/collects/honu/core/private/class.rkt b/collects/honu/core/private/class.rkt index 5e36c603b5..968d005e8f 100644 --- a/collects/honu/core/private/class.rkt +++ b/collects/honu/core/private/class.rkt @@ -34,7 +34,7 @@ (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ name (#%parens arg:honu-expression ...) . rest) - (define new #'(make-object name arg.result ...)) + (define new #'(%racket (make-object name arg.result ...))) (values new #'rest diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt new file mode 100644 index 0000000000..f0bff6cbc8 --- /dev/null +++ b/collects/honu/core/private/compile.rkt @@ -0,0 +1,18 @@ +#lang racket/base + +(require syntax/parse + "literals.rkt" + (for-template racket/base)) + +(provide honu->racket) +(define (honu->racket forms) + (define-literal-set literals (%racket)) + ;; (debug "honu to racket ~a\n" (pretty-format (syntax->datum forms))) + (syntax-parse forms #:literal-sets (literals) + [(%racket x) (honu->racket #'x)] + [(form ...) + (with-syntax ([(form* ...) (map honu->racket (syntax->list #'(form ...)))]) + #'(form* ...))] + [x #'x] + [() forms])) + diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 25b28ee3d2..6349989c1d 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -10,6 +10,7 @@ scheme/splicing macro-debugger/emit racket/pretty + "compile.rkt" "debug.rkt" "contexts.rkt" "util.rkt" @@ -457,17 +458,6 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (define-for-syntax (honu-compile forms) #'(void)) -(define-for-syntax (honu->racket forms) - (define-literal-set literals (%racket)) - ;; (debug "honu to racket ~a\n" (pretty-format (syntax->datum forms))) - (syntax-parse forms #:literal-sets (literals) - [(%racket x) (honu->racket #'x)] - [(form ...) - (with-syntax ([(form* ...) (map honu->racket (syntax->list #'(form ...)))]) - #'(form* ...))] - [x #'x] - [() forms])) - (provide honu-unparsed-begin) (define-syntax (honu-unparsed-begin stx) (emit-remark "Honu unparsed begin!" stx) diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 53cec2a37c..054258b8e7 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -36,6 +36,7 @@ (define-splicing-syntax-class pattern-type #:literal-sets (cruft) [pattern (~seq name colon class) + ;; we know the output of syntactic classes will end with _result #:with result (with-syntax ([name.result (format-id #'name "~a_result" #'name)]) #'(name name.result))] [pattern x #:with result #f]) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index f7f86e85e3..7216ec1041 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -7,6 +7,7 @@ (require ;; "macro2.rkt" "literals.rkt" "debug.rkt" + "compile.rkt" (prefix-in transformer: "transformer.rkt") racket/pretty syntax/stx @@ -147,7 +148,7 @@ (parse-arguments #'(args ...))]) #'(define (function parsed-arguments ...) (let-syntax ([parse-more (lambda (stx) - (parse-all #'(code ...)))]) + (honu->racket (parse-all #'(code ...))))]) (parse-more))))]) ;; E = macro @@ -322,13 +323,9 @@ (syntax-parse #'(stuff ...) #:literal-sets (cruft) [(work:honu-expression colon (~seq variable:id honu-<- list:honu-expression (~optional honu-comma)) ...) (define comprehension - (with-syntax ([(list-parsed ...) (map (lambda (list) - (parse-all list)) - (syntax->list #'(list.result ...)))] - [work-parsed (parse-all #'work.result)]) - #'(for/list ([variable list-parsed] + #'(for/list ([variable list.result] ...) - work-parsed))) + work.result)) (if current (error 'parse "a list comprehension cannot follow an expression") (do-parse #'(rest ...) precedence left comprehension))] @@ -409,7 +406,8 @@ [code code]) (define-values (parsed unparsed) (parse (strip-stops code))) - (debug "Parsed ~a unparsed ~a\n" (if parsed (syntax->datum parsed) parsed) + (debug "Parsed ~a unparsed ~a\n" + (if parsed (syntax->datum parsed) parsed) (if unparsed (syntax->datum unparsed) unparsed)) (if (empty-syntax? unparsed) (with-syntax ([(use ...) (reverse (if parsed