diff --git a/collects/honu/core/private/compile.rkt b/collects/honu/core/private/compile.rkt index beb2e85f7a..face5515ca 100644 --- a/collects/honu/core/private/compile.rkt +++ b/collects/honu/core/private/compile.rkt @@ -2,87 +2,15 @@ (require syntax/parse "debug.rkt" - (for-syntax racket/base "debug.rkt" syntax/parse - macro-debugger/emit) - "literals.rkt") + "literals.rkt" + (for-syntax racket/base + "debug.rkt")) ;; to get syntax as a literal (require (for-template racket/base)) (provide (all-defined-out)) -(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]) - code - ) - -(define-syntax repeat$ (lambda (stx) (raise-syntax-error 'repeat$ "dont use this"))) - -(define (remove-repeats input) - (debug 2 "Remove repeats from ~a\n" (syntax->datum input)) - (debug 2 "Properties ~a\n" (syntax-property-symbol-keys input)) - (define-literal-set locals (repeat$)) - (syntax-parse input #:literal-sets ([locals #:at input]) - [(out ... ((~literal repeat$) stuff ...) rest ...) - (debug 2 " Found a repeat\n") - (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))] - [(stuff* ...) (map remove-repeats (syntax->list #'(stuff ...)))] - [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))]) - (remove-repeats (datum->syntax input - (syntax->list #'(out* ... stuff* ... rest* ...)) - input input)))] - [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))]) - (datum->syntax input - (syntax->list #'(normal* ...)) - input input))] - [x #'x] - [else (raise-syntax-error 'repeats "unhandled case" input)])) - -(define-syntax (unexpand-honu-syntax stx) - (define (remove-repeats input) - (debug 2 "Remove repeats from ~a\n" (syntax->datum input)) - (debug 2 "Properties ~a\n" (syntax-property-symbol-keys input)) - (define-literal-set locals (repeat$)) - (syntax-parse input #:literal-sets (locals) - [(out ... (repeat$ stuff ...) rest ...) - (debug 2 " Found a repeat\n") - (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))] - [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))]) - (remove-repeats (datum->syntax input - (syntax->list #'(out* ... stuff ... rest* ...)) - input input)))] - [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))]) - (datum->syntax input - (syntax->list #'(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)) - (emit-remark (format "Unexpand honu syntax at phase ~a" (syntax-local-phase-level)) - #'expr) - #; - (syntax-case #'expr () - [(_ what) (debug "Properties on ~a are ~a\n" #'what (syntax-property-symbol-keys #'what))]) - (define removed (remove-repeats #'expr)) - (emit-local-step #'expr removed #:id #'unexpand-honu-syntax) - (debug "Cleansed ~a\n" (syntax->datum removed)) - (debug "Syntax properties ~a\n" (syntax-property-symbol-keys removed)) - removed)])) - ; (define parsed-property (gensym 'honu-parsed)) (define parsed-property 'honu-parsed) @@ -103,30 +31,3 @@ (begin (debug 2 "Racket syntax ~a\n" (syntax->datum #'form)) #'(parsed-syntax #'form))])) - -(begin-for-syntax - (provide compress-dollars) - (define (compress-dollars stx) - (define-literal-set local-literals (honu-$ repeat$)) - (define-splicing-syntax-class not-dollar - #:literal-sets (local-literals) - [pattern x #:when (or (not (identifier? #'x)) - (not (free-identifier=? #'honu-$ #'x))) - #:with out #'x]) - (debug 2 "Compress dollars ~a\n" stx) - (syntax-parse stx #:literal-sets (local-literals) - [(honu-$ x:not-dollar ... honu-$ rest ...) - (debug 2 "Compressing ~a\n" #'(x.out ...)) - (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))]) - (datum->syntax stx (syntax->list #'((repeat$ x.out ...) rest* ...)) - stx stx))] - [(honu-$ rest ...) - (error 'compress-dollars "unmatched $ ~a" (syntax->datum stx))] - [(x rest ...) - (with-syntax ([x* (compress-dollars #'x)] - [(rest* ...) (compress-dollars #'(rest ...))]) - (datum->syntax stx - (syntax->list #'(x* rest* ...)) - stx stx))] - [x #'x]))) - diff --git a/collects/honu/core/private/macro2.rkt b/collects/honu/core/private/macro2.rkt index 6e0b2fd927..d450814d74 100644 --- a/collects/honu/core/private/macro2.rkt +++ b/collects/honu/core/private/macro2.rkt @@ -5,6 +5,7 @@ syntax/stx racket/set racket/syntax + "template.rkt" "literals.rkt" (prefix-in phase1: "parse2.rkt") "debug.rkt" @@ -217,11 +218,12 @@ #'rest #t)]))) +#| ;; FIXME: we shouldn't need this definition here (define-syntax (as-honu-syntax stx) (syntax-parse stx [(_ form) - (define compressed (phase0:compress-dollars #'form)) + (define compressed (compress-dollars #'form)) (with-syntax ([stuff* (datum->syntax #'form (syntax->list compressed) #'form #'form)]) (syntax #'stuff*))])) @@ -234,6 +236,7 @@ (with-syntax ([stuff* (datum->syntax #'form (syntax->list compressed) #'form #'form)]) (syntax #'stuff*))]))) +|# (provide honu-syntax) ;; Do any honu-specific expansion here @@ -243,7 +246,7 @@ #; [(_ (#%parens single) . rest) (define context #'single) - (define compressed (phase0:compress-dollars #'single)) + (define compressed (compress-dollars #'single)) (values (with-syntax ([stuff* (datum->syntax context compressed context context)]) (phase1:racket-syntax #'stuff*)) @@ -251,7 +254,7 @@ #f)] [(_ (#%parens stuff ...) . rest) (define context (stx-car #'(stuff ...))) - (define compressed (phase0:compress-dollars #'(stuff ...))) + (define compressed (compress-dollars #'(stuff ...))) (values (with-syntax ([stuff* (datum->syntax context (syntax->list compressed) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 4032b8023f..7963d8d9d8 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -8,6 +8,8 @@ "literals.rkt" "debug.rkt" "compile.rkt" + "template.rkt" + "utils.rkt" racket/list (prefix-in transformer: "transformer.rkt") (prefix-in fixture: "fixture.rkt") @@ -25,7 +27,7 @@ ;; phase -1 (require (for-template racket/base racket/splicing - "compile.rkt" + ;; "compile.rkt" "syntax.rkt" "extra.rkt")) diff --git a/collects/honu/core/private/template.rkt b/collects/honu/core/private/template.rkt new file mode 100644 index 0000000000..b09f0515b1 --- /dev/null +++ b/collects/honu/core/private/template.rkt @@ -0,0 +1,95 @@ +#lang racket/base + +(require syntax/parse + "literals.rkt" + "debug.rkt" + (for-syntax racket/base + "debug.rkt" + syntax/parse + macro-debugger/emit + )) + +(provide (all-defined-out)) + +(define-syntax repeat$ (lambda (stx) (raise-syntax-error 'repeat$ "dont use this"))) + +(define (remove-repeats input) + (debug 2 "Remove repeats from ~a\n" (syntax->datum input)) + (debug 2 "Properties ~a\n" (syntax-property-symbol-keys input)) + (define-literal-set locals (repeat$)) + (syntax-parse input #:literal-sets ([locals #:at input]) + [(out ... ((~literal repeat$) stuff ...) rest ...) + (debug 2 " Found a repeat\n") + (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))] + [(stuff* ...) (map remove-repeats (syntax->list #'(stuff ...)))] + [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))]) + (remove-repeats (datum->syntax input + (syntax->list #'(out* ... stuff* ... rest* ...)) + input input)))] + [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))]) + (datum->syntax input + (syntax->list #'(normal* ...)) + input input))] + [x #'x] + [else (raise-syntax-error 'repeats "unhandled case" input)])) + +(define-syntax (unexpand-honu-syntax stx) + (define (remove-repeats input) + (debug 2 "Remove repeats from ~a\n" (syntax->datum input)) + (debug 2 "Properties ~a\n" (syntax-property-symbol-keys input)) + (define-literal-set locals (repeat$)) + (syntax-parse input #:literal-sets (locals) + [(out ... (repeat$ stuff ...) rest ...) + (debug 2 " Found a repeat\n") + (with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))] + [(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))]) + (remove-repeats (datum->syntax input + (syntax->list #'(out* ... stuff ... rest* ...)) + input input)))] + [(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))]) + (datum->syntax input + (syntax->list #'(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)) + (emit-remark (format "Unexpand honu syntax at phase ~a" (syntax-local-phase-level)) + #'expr) + #; + (syntax-case #'expr () + [(_ what) (debug "Properties on ~a are ~a\n" #'what (syntax-property-symbol-keys #'what))]) + (define removed (remove-repeats #'expr)) + (emit-local-step #'expr removed #:id #'unexpand-honu-syntax) + (debug "Cleansed ~a\n" (syntax->datum removed)) + (debug "Syntax properties ~a\n" (syntax-property-symbol-keys removed)) + removed)])) + +(define (compress-dollars stx) + (define-literal-set local-literals (honu-$ repeat$)) + (define-splicing-syntax-class not-dollar + #:literal-sets (local-literals) + [pattern x #:when (or (not (identifier? #'x)) + (not (free-identifier=? #'honu-$ #'x))) + #:with out #'x]) + (debug 2 "Compress dollars ~a\n" stx) + (syntax-parse stx #:literal-sets (local-literals) + [(honu-$ x:not-dollar ... honu-$ rest ...) + (debug 2 "Compressing ~a\n" #'(x.out ...)) + (with-syntax ([(rest* ...) (compress-dollars #'(rest ...))]) + (datum->syntax stx (syntax->list #'((repeat$ x.out ...) rest* ...)) + stx stx))] + [(honu-$ rest ...) + (error 'compress-dollars "unmatched $ ~a" (syntax->datum stx))] + [(x rest ...) + (with-syntax ([x* (compress-dollars #'x)] + [(rest* ...) (compress-dollars #'(rest ...))]) + (datum->syntax stx + (syntax->list #'(x* rest* ...)) + stx stx))] + [x #'x])) diff --git a/collects/honu/core/private/utils.rkt b/collects/honu/core/private/utils.rkt new file mode 100644 index 0000000000..1ec7e1f329 --- /dev/null +++ b/collects/honu/core/private/utils.rkt @@ -0,0 +1,19 @@ +#lang racket/base + +(require syntax/parse + "literals.rkt") + +(provide (all-defined-out)) + +(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]) + code + )