From 70589a7033449d1591afb4c021be6687bc4563f4 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Thu, 17 Nov 2011 23:27:11 -0700 Subject: [PATCH] [honu] create a new syntax class for parsing expressions at current-phase + 1. allow new operators to be defined using honu syntax --- collects/honu/core/private/compile.rkt | 10 +-- .../honu/core/private/honu-typed-scheme.rkt | 4 +- collects/honu/core/private/honu2.rkt | 86 +++++++++++++++++-- collects/honu/core/private/macro2.rkt | 43 ++++++---- collects/honu/core/private/parse2.rkt | 41 ++++++--- collects/tests/honu/macros.rkt | 6 +- collects/tests/honu/operators.rkt | 11 +++ 7 files changed, 154 insertions(+), 47 deletions(-) create mode 100644 collects/tests/honu/operators.rkt diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt index f0bff6cbc8..fba2b1cc1d 100644 --- a/collects/honu/core/private/compile.rkt +++ b/collects/honu/core/private/compile.rkt @@ -1,18 +1,18 @@ #lang racket/base (require syntax/parse - "literals.rkt" - (for-template racket/base)) + "literals.rkt") (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* ...))] + (datum->syntax forms + (map honu->racket (syntax->list #'(form ...))) + forms + forms)] [x #'x] [() forms])) diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 4076217ca0..57c24d4a4a 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -28,8 +28,8 @@ ;; "typed-utils.ss" ) -(require (for-meta 2 scheme/base "util.rkt")) -(require (for-meta 3 scheme/base)) +(require (for-meta 2 racket/base "util.rkt")) +(require (for-meta 3 racket/base)) (provide (all-defined-out)) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 33ac08f330..690012cfda 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -17,15 +17,30 @@ %racket) (for-syntax syntax/parse syntax/parse/experimental/reflect + syntax/parse/experimental/splicing racket/syntax + racket/pretty + "compile.rkt" "util.rkt" "debug.rkt" "literals.rkt" "parse2.rkt" - racket/base)) + racket/base) + (for-meta 2 racket/base + syntax/parse + racket/pretty + macro-debugger/emit + "compile.rkt" + "debug.rkt" + "parse2.rkt")) (provide (all-from-out "struct.rkt")) +(define-syntax (parse-body stx) + (syntax-parse stx + [(_ stuff ...) + (honu->racket (parse-all #'(stuff ...)))])) + (provide honu-function) (define-honu-syntax honu-function (lambda (code context) @@ -35,9 +50,7 @@ . rest) (values #'(%racket (lambda (arg ...) - (let-syntax ([do-parse (lambda (stx) - (parse-all #'(code ...)))]) - (do-parse)))) + (parse-body code ...))) #'rest #f)]))) @@ -105,11 +118,11 @@ (lambda (left right) (with-syntax ([left left] [right right]) - #'(operator left right))) + #'(%racket (operator left right)))) ;; unary (lambda (argument) (with-syntax ([argument argument]) - #'(operator argument)))))) + #'(%racket (operator argument))))))) (define-syntax-rule (define-unary-operator name precedence associativity operator) (begin @@ -119,7 +132,51 @@ ;; unary (lambda (argument) (with-syntax ([argument argument]) - #'(operator argument)))))) + #'(%racket (operator argument))))))) +(begin-for-syntax + +(define-syntax (parse-expression stx) + (syntax-parse stx + [(_ (syntax-ignore (stuff ...))) + (debug "Parse expression ~a\n" (pretty-format (syntax->datum #'(stuff ...)))) + (define-values (parsed unparsed) + (parse #'(stuff ...))) + (with-syntax ([parsed* (honu->racket parsed)] + [unparsed unparsed]) + (emit-local-step parsed #'parsed* #:id #'honu-parse-expression) + (debug "Parsed ~a. Unparsed ~a\n" #'parsed #'unparsed) + ;; we need to smuggle our parsed syntaxes through the macro transformer + #'(#%datum parsed* unparsed))])) + +(define-primitive-splicing-syntax-class (honu-expression/phase+1) + #:attributes (result) + #:description "expression at phase + 1" + (lambda (stx fail) + (debug "honu expression phase + 1: ~a\n" (pretty-format (syntax->datum stx))) + (define transformed + (with-syntax ([stx stx]) + (local-transformer-expand #'(parse-expression #'stx) + 'expression '()))) + (debug "Transformed ~a\n" (pretty-format (syntax->datum transformed))) + (define-values (parsed unparsed) + (syntax-parse transformed + [(ignore-quote (parsed unparsed)) (values #'parsed + #'unparsed)])) + (debug "Parsed ~a unparsed ~a\n" parsed unparsed) + (list (parsed-things stx unparsed) + (with-syntax ([parsed parsed]) + #'(%racket parsed))))) + +) ;; begin-for-syntax + +(provide define-make-honu-operator) +(define-honu-syntax define-make-honu-operator + (lambda (code context) + (syntax-parse code + [(_ name:id level:number association:honu-expression function:honu-expression/phase+1 . rest) + (debug "Operator function ~a\n" (syntax->datum #'function.result)) + (define out #'(%racket (define-honu-operator/syntax name level association.result function.result))) + (values out #'rest #t)]))) (provide honu-dot) (define-honu-operator/syntax honu-dot 10000 'left @@ -141,14 +198,14 @@ (lambda (left right) (with-syntax ([left left] [right right]) - #'(right left)))) + #'(%racket (right left))))) (provide honu-assignment) (define-honu-operator/syntax honu-assignment 0.0001 'left (lambda (left right) (with-syntax ([left left] [right right]) - #'(set! left right)))) + #'(%racket (set! left right))))) (define-binary-operator honu-+ 1 'left +) (define-binary-operator honu-- 1 'left -) @@ -308,3 +365,14 @@ (define result #'(%racket (define-values (var.name ...) var.expression))) (values result #'rest #t)]))) +(provide (rename-out [honu-with-syntax withSyntax])) +(define-honu-syntax honu-with-syntax + (lambda (code context) + (syntax-parse code #:literal-sets (cruft) + #:literals (honu-->) + [(_ (~seq name:id honu--> data:honu-expression (~optional honu-comma)) ... + (#%braces code ...) . rest) + (define out #'(%racket (with-syntax ([name data.result] ...) + (parse-body code ...)))) + (values out #'rest #t)]))) + diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index a44ff28f17..2f42d2f3f2 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) "literals.rkt" #; @@ -44,6 +45,11 @@ [(thing:pattern-type ...) (filter (lambda (x) (syntax-e x)) (syntax->list #'(thing.result ...)))])) +(define-syntax (parse-stuff stx) + (syntax-parse stx + [(_ stuff ...) + (honu->racket (parse-all #'(stuff ...)))])) + (provide honu-macro) (define-honu-syntax honu-macro (lambda (code context) @@ -56,8 +62,7 @@ (with-syntax ([(syntax-parse-pattern ...) (convert-pattern #'(pattern ...))] [((pattern-variable.name pattern-variable.result) ...) - (find-pattern-variables #'(pattern ...))] - [(code ...) (parse-all #'(action ...))]) + (find-pattern-variables #'(pattern ...))]) #'(%racket (define-honu-syntax name (lambda (stx context-name) (syntax-parse stx @@ -69,33 +74,35 @@ ;; instead of x_result. x_result is still there, too (with-syntax ([pattern-variable.name #'pattern-variable.result] ...) - (code ...)) + (parse-stuff action ...) + #; + (let-syntax ([parse-more (lambda (stx) + (parse-all #'(action ...)))]) + (parse-more))) #'more #t)]))))) #'rest #t)]))) -(provide (rename-out [honu-with-syntax withSyntax])) -(define-honu-syntax honu-with-syntax - (lambda (code context) - (syntax-parse code #:literal-sets (cruft) - [(_ [#%brackets name:id data] - (#%braces code ...)) - #'(%racket (with-syntax ([name data]) code ...))]))) - -#; -(define-syntax (parse-stuff stx) - (syntax-parse stx - [(_ stuff ...) - (parse-all #'(stuff ...))])) - (provide honu-syntax) ;; Do any honu-specific expansion here (define-honu-syntax honu-syntax (lambda (code context) (syntax-parse code #:literal-sets (cruft) [(_ (#%parens stuff ...) . rest) + (define context (stx-car #'(stuff ...))) (values - #'(%racket #'(stuff ...)) + (with-syntax ([stuff* (datum->syntax context + (syntax->list #'(stuff ...)) + context context)]) + #'(%racket #'stuff*)) #; #'(%racket-expression (parse-stuff stuff ...)) #'rest #f)]))) + +;; combine syntax objects +;; #'(a b) + #'(c d) = #'(a b c d) +(provide mergeSyntax) +(define (mergeSyntax syntax1 syntax2) + (with-syntax ([(syntax1* ...) syntax1] + [(syntax2* ...) syntax2]) + #'(syntax1* ... syntax2* ...))) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index c614ade39d..df504575a4 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -10,12 +10,14 @@ "compile.rkt" (prefix-in transformer: "transformer.rkt") (prefix-in fixture: "fixture.rkt") + macro-debugger/emit racket/pretty syntax/stx syntax/parse/experimental/splicing syntax/parse) ;; phase 1 -(require-syntax racket/base) +(require-syntax racket/base + "debug.rkt") ;; phase -1 (require (for-template racket/base @@ -158,6 +160,8 @@ (parse-arguments #'(args ...))]) #'(define (function parsed-arguments ...) (let-syntax ([parse-more (lambda (stx) + ;; this adds an extra mark, you might not + ;; want that (honu->racket (parse-all #'(code ...))))]) (parse-more))))]) @@ -198,13 +202,17 @@ (if current (values (left current) stream) (begin - (debug "Honu macro ~a\n" head) + (debug "Honu macro at phase ~a: ~a\n" (syntax-local-phase-level) head) (let-values ([(parsed unparsed terminate?) ((syntax-local-value head) (with-syntax ([head head] [(rest ...) rest]) - #'(head rest ...)) + (datum->syntax #'head (syntax->list #'(head rest ...)) + #'head #'head)) #f)]) + (emit-remark parsed) + #; + (emit-local-step stream parsed #:id #'do-macro) (with-syntax ([parsed parsed] [rest unparsed]) (debug "Output from macro ~a\n" (pretty-format (syntax->datum #'parsed))) @@ -215,7 +223,9 @@ (parse #'parsed)]) (with-syntax ([(re-parse* ...) re-parse] [(re-unparse* ...) re-unparse]) - #'(re-parse* ... re-unparse* ...)))) + (datum->syntax re-parse + (syntax->list #'(re-parse* ... re-unparse* ...)) + re-parse re-parse)))) (if terminate? (values (left re-parse) #'rest) @@ -282,14 +292,19 @@ (if (higher new-precedence precedence) (let-values ([(parsed unparsed) (do-parse #'(rest ...) new-precedence - (lambda (stuff) - (if current - (if binary-transformer - (binary-transformer current stuff) - (error '#'head "cannot be used as a binary operator")) - (if unary-transformer - (unary-transformer stuff) - (error '#'head "cannot be used as a unary operator")))) + (lambda (stuff) + (define output + (if current + (if binary-transformer + (binary-transformer current stuff) + (error '#'head "cannot be used as a binary operator")) + (if unary-transformer + (unary-transformer stuff) + (error '#'head "cannot be used as a unary operator")))) + (emit-local-step stuff output #:id #'binary-transformer) + (with-syntax ([out (parse-all output)]) + #'(%racket out))) + #f)]) (do-parse unparsed precedence left parsed)) @@ -442,6 +457,7 @@ (loop (cons parsed all) unparsed)))) +(provide parsed-things) ;; rest will be some subset of full (define (parsed-things full rest) (define full-datum (syntax->datum full)) @@ -480,3 +496,4 @@ #:with result #'(let-syntax ([parse-more (lambda (stx) (honu->racket (parse-all #'(code ...))))]) (parse-more))]) + diff --git a/collects/tests/honu/macros.rkt b/collects/tests/honu/macros.rkt index b1365826ef..8c217a6967 100644 --- a/collects/tests/honu/macros.rkt +++ b/collects/tests/honu/macros.rkt @@ -1,6 +1,10 @@ #lang honu -macro testx () {x:expression} {syntax(x + 1)} +macro testx () {x:expression} { + var out1 = syntax(x) + var out2 = syntax(+ 1) + mergeSyntax(out1, out2) +} testx 5 * 2 diff --git a/collects/tests/honu/operators.rkt b/collects/tests/honu/operators.rkt new file mode 100644 index 0000000000..c7b20603c6 --- /dev/null +++ b/collects/tests/honu/operators.rkt @@ -0,0 +1,11 @@ +#lang honu + +operator gg 2 'left + function(left right){ + withSyntax left -> left, + right -> right { + syntax(left * 2 - right) + } + } + +3 gg 4 gg 5