diff --git a/collects/honu/core/main.rkt b/collects/honu/core/main.rkt index 2191b5a7c2..63f65eeed2 100644 --- a/collects/honu/core/main.rkt +++ b/collects/honu/core/main.rkt @@ -5,7 +5,6 @@ (require racket/class) (require "private/honu-typed-scheme.rkt" - ;; "private/honu.ss" "private/parse.ss" (for-syntax "private/literals.rkt") (for-syntax "private/honu-typed-scheme.rkt") @@ -23,19 +22,6 @@ (for-syntax "private/macro.rkt") "private/macro.ss") -(define test-x-class - (class object% - (init-field tuna) - (super-new))) - -(define x (new test-x-class [tuna 5])) - -(define (sql1 . x) #f) -(define (sql2) #f) -(define (sql3) #f) -(define (sql4) #f) -(define (sql5) #f) - (define-for-syntax (syntax-to-string stx) (format "original '~a' - ~a" (syntax->datum stx) (to-honu-string stx))) @@ -51,7 +37,6 @@ (define name (lambda args (apply make-object new-name args)))))])) (provide (rename-out (#%dynamic-honu-module-begin #%module-begin) - ;; (honu-top #%top) (semicolon \; ) (honu-+ +) @@ -75,22 +60,10 @@ (expression-comma expression_comma) ) - #; - (rename-out [honu-print print]) - (for-syntax (rename-out [syntax-to-string syntax_to_string])) #%top - ;; sql nonsense - (rename-out - (sql1 SQL_create_insert) - (sql2 foo) - (sql3 cheese) - (sql4 monkeys) - (sql5 horse)) - ;; end sql - #%datum (for-template #%datum) datum->syntax @@ -104,7 +77,6 @@ ... map syntax->list - ;identifier expression statement (rename-out (semicolon \; @@ -144,15 +116,10 @@ (for-template #%app) quote ... - foobar2000 expression str - ;; define-struct - #; - (for-template #%parens #%brackets #%braces) in-range honu-struct - ;; (for-meta 2 (rename-out (honu-syntax syntax))) (rename-out (struct scheme-struct) (syntax real-syntax) @@ -170,55 +137,5 @@ (honu-syntax syntax) (honu-pattern pattern) (honu-keywords keywords) - #; - (honu-scheme scheme2) (scheme-syntax scheme:syntax) )) - -#; -(provide int real bool obj - function var const - string - -> >-> - \; - ? : - && \|\| - / - < > <= >= - != - cons list - true false - display write newline - #%datum - #%top - #%parens #%brackets #%braces #%angles - #%prefix #%postfix - ;; define-honu-syntax - ... - (for-syntax ...) - - (rename-out (set! =) - (honu-return return) - (honu-if if) - (honu-macro macro) - (honu-time time) - (honu-class class) - (honu+ +) - (honu- -) - (honu* *) - (do do) - (honu-end end) - (modulo %) - (equal? ==) - (string->number stringToNumber) - (number->string numberToString) - (car first) - (cdr rest) - (null empty) - (null? isEmpty) - (pair? isCons) - (#%dynamic-honu-module-begin #%module-begin) - (honu-#%app #%app) - (honu-top #%top-interaction) - (honu-provide provide) - (honu-require require))) diff --git a/collects/honu/core/private/honu-typed-scheme.rkt b/collects/honu/core/private/honu-typed-scheme.rkt index 2bc05f4400..9f0f1c1a5c 100644 --- a/collects/honu/core/private/honu-typed-scheme.rkt +++ b/collects/honu/core/private/honu-typed-scheme.rkt @@ -28,16 +28,8 @@ (provide (all-defined-out)) -;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) - (begin-for-syntax -;; these functions use parse-block-one -;; (define parse-a-tail-expr #f) -;; (define parse-an-expr #f) -;; (set! parse-a-tail-expr parse-tail-expr) -;; (set! parse-an-expr parse-expr) - (define parse-expr ;; The given syntax sequence must not be empty (let () @@ -75,15 +67,7 @@ (let ([trans (get-transformer #'pexpr)]) (let-values ([(expr-or-type rest) (trans #'pexpr the-type-or-expression-context)]) (cons expr-or-type - (start-operator #'(expr . more))) - #; - (if (honu-type? expr-or-type) - ;; parens as a unary prefix operator - (cons (make-cast-prefix (stx-car (stx-car stx)) expr-or-type) - (start-expr #'(expr . more))) - ;; must have been an expression - (cons expr-or-type - (start-operator #'(expr . more))))))] + (start-operator #'(expr . more)))))] [((#%braces . pexpr)) (if (stx-null? #'pexpr) (raise-syntax-error @@ -165,19 +149,6 @@ (cond [(null? seq) (cond - #; - [(cast-prefix? op) - (let ([after (reverse since)]) - (group (append (reverse before) - (list (quasisyntax/loc (op-id op) - (op-cast #,(op-id op) - #,(let ([t (cast-prefix-type op)]) - (list (honu-type-stx t) - (honu-type-name-stx t) - (honu-type-pred-stx t) - (honu-type-protect-stx t))) - #,(car after)))) - (cdr after))))] [(prefix? op) (let ([after (reverse since)]) (group (append (reverse before) @@ -278,13 +249,6 @@ )) parse-one )])) -#| -(define-honu-macro (e ... * e ... \;)) - -(foo . bar ()) -x(2) -|# - (define (parse-block stx ctx) (let loop ([stx stx]) (parse-block-one ctx @@ -333,16 +297,6 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (syntax/loc stx (define-syntax id (make-honu-infix-transformer rhs)))))) -#; -(define-honu-syntax honu-provide - (lambda (stx ctx) - (syntax-parse stx - #:literals (semicolon) - [(_ something:id semicolon . rest) - (values #'(provide something) - #'rest)]))) - -;; (honu-syntax ...) (define-honu-syntax honu-macro-item (lambda (stx ctx) @@ -377,23 +331,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (define (parse-complete-block stx) ;; (debug "Parsing complete block ~a\n" (syntax->datum stx)) (with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)]) - #'(begin exprs ...)) - #; - (let-values ([(a b) - (parse-block-one - (if (block-context-return? ctx) - the-expression-return-block-context - the-expression-block-context) - stx - (lambda (expr rest) - (values expr rest)) - (lambda () - (raise-syntax-error - #f - "expected a braced block or a statement" - )))]) - (debug "Result is ~a and ~a\n" a b) - a)) + #'(begin exprs ...))) ;; TODO: move these syntax classes to a module (define-syntax-class expr [pattern e]) @@ -402,9 +340,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt [pattern (#%parens expr:expression) #:with result #'expr.result]) (define-syntax-class block [pattern (#%braces statement ...) - #:with line #'(honu-unparsed-begin statement ...) - #; - (parse-complete-block #'(statement ...))]) + #:with line #'(honu-unparsed-begin statement ...)]) ;; (debug "Original syntax ~a\n" (syntax->datum stx)) (syntax-parse stx #:literals (else) @@ -414,80 +350,13 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt (let ([result #'(if condition.result on-true.line on-false.line)]) (values (lambda () result) - #'rest) - #; - (expression-result ctx result (syntax/loc #'rest rest)))] + #'rest))] [(_ condition:paren-expr on-true:block . rest) ;; (debug "used if with no else\n") (let ([result #'(when condition.result on-true.line)]) (values (lambda () result) - #'rest) - #; - (expression-result ctx result #'rest))]))) - -#| -if (foo){ - blah.. -} else { -} - -|# - -#; -(define-honu-syntax honu-if - (lambda (stx ctx) - (define (get-block-or-statement kw rest) - (syntax-parse rest (#%braces) - [((#%braces then ...) . rrest) - (values - #`(honu-unparsed-block #f obj 'obj #f #,(and (block-context-return? ctx) - (stx-null? rest)) - . #,(stx-cdr (stx-car rest))) - #'rrest)] - [else - (parse-block-one (if (block-context-return? ctx) - the-expression-return-block-context - the-expression-block-context) - rest - (lambda (expr rest) - (values expr rest)) - (lambda () - (raise-syntax-error - #f - "expected a braced block or a statement" - kw)))])) - - (unless (block-context? ctx) - (raise-syntax-error - #f - "allowed only in a block context" - (stx-car stx))) - - (syntax-parse stx (#%parens) - [(_ (#%parens test ...) . rest) - (let* ([tests #'(test ...)]) - (when (stx-null? tests) - (raise-syntax-error - #f - "missing test expression" - (stx-car stx) - (stx-car (stx-cdr stx)))) - (let ([test-expr (parse-expr (syntax->list tests))]) - (let-values ([(then-exprs rest) (get-block-or-statement (stx-car stx) #'rest)]) - (syntax-case rest (else) - [(else . rest2) - (let-values ([(else-exprs rest) (get-block-or-statement (stx-car rest) #'rest2)]) - (expression-result ctx - #`(if (as-test #,test-expr) #,then-exprs #,else-exprs) - rest))] - [_else - (expression-result ctx #`(if (as-test #,test-expr) #,then-exprs (void)) rest)]))))] - [_else - (raise-syntax-error - #f - "expected a parenthesized test after `if' keyword" - (stx-car stx))]))) + #'rest))]))) (define true #t) (define false #f) @@ -513,11 +382,6 @@ if (foo){ (debug "Honu ~a\n" (syntax->datum stx)) (raise-syntax-error #f "interactive use is not yet supported")) -(define-syntax (foobar2000 stx) - (debug "Called foobar2000 on ~a\n" (syntax->datum stx)) - (syntax-case stx () - [(_ x y ...) #'(debug "foobar2000 ~a\n" x)])) - (define (display2 x y) (debug "~a ~a" x y)) @@ -581,88 +445,16 @@ if (foo){ #'(form.result ...)) body body)) - #'rest)]) - #; - (syntax-parse body #:literals (#%parens honu-for-syntax semicolon) - [(_ (#%parens honu-for-syntax what) semicolon . rest) - (values - (lambda () - (apply-scheme-syntax - #'(require (for-syntax what)))) #'rest)]))) -#; -(define-splicing-syntax-class unparsed - [pattern (~seq x ...) #:with result #'(honu-unparsed-begin x ...)]) - (define-syntax (honu-unparsed-begin stx) (emit-remark "Honu unparsed begin!" stx) - #; - (emit-remark "Honu unparsed begin" stx) (debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level)) - #'(void) - #; - (syntax-case stx () - [(_) #'(void)] - [(_ . body) - (begin - (debug "Body is ~a\n" #'body) - (let-values ([(code rest) (parse-block-one/2 #'body - the-top-block-context - #; - the-expression-context - #; - the-top-block-context)]) - ;; (debug "Rest is ~a\n" (syntax->datum rest)) - (with-syntax ([code code] - [(rest ...) rest]) - (if (stx-null? #'(rest ...)) - (syntax/loc stx - code) - #; - (if (raw-scheme? #'code) - (syntax/loc stx - code) - (with-syntax ([(code* ...) #'code]) - (syntax/loc stx (honu-unparsed-begin code* ...)))) - (syntax/loc stx - (begin code (honu-unparsed-begin rest ...))) - #; - (if (raw-scheme? #'code) - (syntax/loc stx - (begin code (honu-unparsed-begin rest ...))) - (with-syntax ([(code* ...) #'code]) - (syntax/loc stx (honu-unparsed-begin code* ... rest ...))))))))] - #; - [(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context - #'body - values - (lambda () - (values #'(void) null)))]) - (with-syntax ([code code] - [(rest ...) rest]) - #'(begin code (honu-unparsed-begin rest ...))))])) - -#; -(define-syntax-rule (#%dynamic-honu-module-begin forms ...) - #; - (#%module-begin-typed-scheme - ;; (require honu/private/typed-utils) - (honu-unparsed-begin forms ...)) - (#%plain-module-begin (honu-unparsed-begin forms ...))) - -#; -(define (honu-print arg) - (debug "~a\n" arg)) + #'(void)) (define-syntax (#%dynamic-honu-module-begin stx) (syntax-case stx () [(_ forms ...) (begin (debug "Module begin ~a\n" (syntax->datum #'(forms ...))) - #'(#%plain-module-begin (honu-unparsed-begin forms ...)) - #; - (with-syntax ([all (syntax-local-introduce #'(provide (all-defined-out)))]) - #'(#%plain-module-begin all (honu-unparsed-begin forms ...)) - #; - #'(#%plain-module-begin (provide (all-defined-out)) (honu-unparsed-begin forms ...))))])) + #'(#%plain-module-begin (honu-unparsed-begin forms ...)))])) diff --git a/collects/honu/core/private/macro.rkt b/collects/honu/core/private/macro.rkt index d550877545..7e3cf142b6 100644 --- a/collects/honu/core/private/macro.rkt +++ b/collects/honu/core/private/macro.rkt @@ -10,8 +10,6 @@ racket/base) (for-meta -3 (only-in "literals.rkt" (#%parens literal-parens))) - #; - (for-template (only-in "literals.rkt" (#%parens literal-parens))) (for-syntax "debug.ss" "contexts.ss" "parse.ss" @@ -44,9 +42,6 @@ [(any : attribute rest ...) ;; todo: export honu attributes for syntax/parse (loop (cons #'(any expr) out) - #'(rest ...)) - #; - (loop (cons #'(any attribute) out) #'(rest ...))] [(foo rest1 rest ...) (loop out #'(rest1 rest ...))] @@ -67,24 +62,6 @@ #'(rest1 rest ...)))] [(foo) (reverse (cons #'foo out))]))) -#| -(define-for-syntax (convert stx) - (syntax-case stx (...) - [(_ x ...) - |# - -#; -(define-for-syntax (get-attributes stx) - (define (attach name attributes) - (list)) - (syntax-parse stx #:literals (honu-:) - [(variable:identifier honu-: class:identifier rest ...) - (let ([vs (attach #'variable (syntax-class-attributes (attribute class)))]) - (append vs (get-attributes #'(rest ...))))] - [(one rest ...) (append (get-attributes #'one) - (get-attributes #'(rest ...)))] - [else (list)])) - (define-for-syntax (fix-template stx) (define (fix-classes stx) (syntax-parse stx #:literals (honu-:) @@ -92,17 +69,13 @@ (with-syntax ([(rest* ...) (fix-template #'(rest ...))]) (datum->syntax stx (cons #'(~var variable class #:attr-name-separator "_") #'(rest* ...)) - stx) - #; - #'((~var variable class) rest* ...))] + stx))] [(one rest ...) (with-syntax ([one* (fix-template #'one)] [(rest* ...) (fix-template #'(rest ...))]) (datum->syntax stx (cons #'one* #'(rest* ...)) - stx) - #; - #'(one* rest* ...))] + stx))] [else stx])) ;; removes commas from a pattern (define (fix-commas stx) @@ -114,14 +87,6 @@ [(rest* ...) (fix-commas #'(rest ...))]) (datum->syntax stx `((~seq ,#'a* (~optional |,|)) ... ,@#'(rest* ...)) - stx stx) - #; - (datum->syntax stx - (cons - #'a* - (cons - #'(... ...) - #'(rest* ...))) stx stx))] [(z rest ...) (with-syntax ([z* (fix-commas #'z)] @@ -133,114 +98,10 @@ (define all-fixes (compose fix-commas fix-classes)) (all-fixes stx)) -#| -(define-for-syntax (fix-template stx) - [(any \; - (... ...) rest1 rest ...) - (loop (cons #'(semicolon any (... ..))) - #'(rest1 rest ...))] - [((any1 any ...) rest1 rest ...) - (loop (loop out #'(any1 any ...)) - #'(rest1 rest ...))] - |# - - -;; x = 1 + y; ... - -#; -(define-honu-syntax honu-macro - (lambda (stx ctx) - (debug "Original macro: ~a\n" (syntax->datum stx)) - (syntax-case stx (#%parens #%braces) - [(_ (#%parens honu-literal ...) - (#%braces (#%braces name pattern ...)) - (#%braces (#%braces template ...)) - . rest) - (with-syntax ([(conventions ...) - (extract-conventions #'(pattern ...))] - [(raw-patterns ...) - (extract-patterns #'(pattern ...))] - [(fixed-template ...) - (fix-template #'(template ...))]) - (debug "new template ~a\n" (syntax->datum #'(fixed-template ...))) - (values - (syntax/loc - stx - (begin - #| - (define honu-literal (lambda () (error 'honu-literal "cant use this"))) - ... - |# - (define-honu-syntax name - (lambda (stx ctx) - (debug "Try to match against pattern ~a. Literals ~a\n" '(name raw-patterns ... . rrest) '(honu-literal ...)) - (debug "stx is ~a\n" (syntax->datum stx)) - ;; (debug "head is ~a\n" (stx-car stx)) - ;; (debug "= is ~a\n" =) - (debug "my matcher ~a\n" - (syntax-case stx (to set! do honu-end honu-literal ...) - [(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))] - [(name raw-patterns ...) - 'ok2] - [(name pattern ...) 'ok5] - [(name v (... ...) honu-literal ...) 'ok4] - [(name v (... ...)) 'ok3] - #; - [(name v (... ...)) (syntax->datum #'(v (... ...)))] - [else 'bad])) - #; - (debug "case pattern ~a\n" - #'(syntax-case stx - (honu-literal ...) - [(name pattern ...) - #'(honu-unparsed-block - #f obj 'obj #f ctx - fixed-template ...)])) - - (let ([result (syntax-case stx - #; - (to set! do honu-end) - (honu-literal ...) - #; - [(name q set! v to m do bb (... ...) honu-end) (syntax->datum #'(bb (... ...)))] - [(name pattern ...) 'ok] - [(name raw-patterns ...) - #'(honu-unparsed-block - #f obj 'obj #f ctx - fixed-template ...)] - [else 'fail-boat])]) - (debug "result was ~a\n" result)) - (syntax-case stx (honu-literal ...) - [(name raw-patterns ... . rrest) - (values - #'(honu-unparsed-block - #f obj 'obj #f ctx - fixed-template ...) - #'rrest)]))) - #; - (define-honu-syntax name - (lambda (stx ctx) - (define-conventions honu-conventions conventions ...) - #; - (debug "Hello from ~a transformer. Syntax is ~a\n" 'name (syntax->datum stx)) - (syntax-parse stx - #:literals (honu-literal ...) - #:conventions (honu-conventions) - [(name raw-patterns ... . rrest) - (values - #'(honu-unparsed-block - #f obj 'obj #f ctx - fixed-template ...) - #'rrest)]))))) - #'rest))]) - )) (define-for-syntax (delimiter? x) (or (free-identifier=? x #'\;))) -(define-syntax (my-ellipses stx) (raise-syntax-error 'my-ellipses "dont use this")) -;; (define-syntax (wrapped stx) (raise-syntax-error 'wrapped "dont use wrap")) -;; just a phase 0 identifier (define wrapped #f) (define unwrap #f) @@ -265,9 +126,7 @@ (loop (cons #'(... ...) ellipses) body (cdr stx))] [(and (identifier? (car stx)) (free-identifier=? (car stx) #'\;)) - ;; (debug "Found a ; in ~a\n" (syntax->datum stx)) (with-syntax ([all (cdr stx)]) - ;; (debug "Found a ; -- ~a\n" (syntax->datum #'all)) (syntax-parse #'all [((~and x (~not _:stop-class)) ... stop:stop-class y ...) (with-syntax ([(ellipses ...) ellipses] @@ -292,67 +151,12 @@ (loop (cons (reverse-syntax wrapped) all) (syntax->list rest)))] [else (loop (cons head all) tail)]))))) -;; rename this to wrap -#; -(define-for-syntax (pull stx) - (define (reverse-syntax stx) - (with-syntax ([(x ...) (reverse (syntax->list stx))]) - #'(x ...))) - (define-syntax-class delimiter-class - (pattern x:id #:when (delimiter? #'x))) - (define-syntax-class ellipses-class - (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) - (define-syntax-class not-ellipses-class - (pattern x:id #:when (not (free-identifier=? #'x #'(... ...))))) - ;; use this if you are defining your own ellipses identifier - #; - (define-syntax-class ellipses-class - #:literals (...) - (pattern my-ellipses)) - (if (not (stx-pair? stx)) - stx - (let ([stx (reverse (syntax->list stx))]) - ;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...)) - ;; (debug "stx is ~a\n" stx) - ;; (debug "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx))) - (syntax-parse stx - [(before:not-ellipses-class ... ellipses1:ellipses-class ellipses:ellipses-class ... delimiter:delimiter-class x ...) - (with-syntax ([(x* ...) (reverse-syntax (pull #'(delimiter x ...)))]) - (reverse-syntax - (with-syntax ([wrapped #'wrapped] - [original - (with-syntax ([(ellipses* ...) (map (lambda (_) - #'((... ...) (... ...))) - (syntax->list #'(ellipses1 ellipses ...)))] - [(x-new ...) (generate-temporaries #'(delimiter x ...))]) - (reverse-syntax #'(before ... ellipses* ... x-new ...)))] - #; - [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))]) - #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))] - [(ellipses1:ellipses-class ellipses:ellipses-class ... x ...) - (with-syntax ([(x* ...) (reverse-syntax (pull #'(x ...)))]) - (reverse-syntax - (with-syntax ([wrapped #'wrapped] - [original - (with-syntax ([(ellipses* ...) (map (lambda (_) - #'((... ...) (... ...))) - (syntax->list #'(ellipses1 ellipses ...)))] - [(x-new ...) (generate-temporaries #'(x ...))]) - (reverse-syntax #'(ellipses* ... x-new ...)))] - #; - [original (syntax->datum (reverse-syntax #'(ellipses1 ellipses ... x ...)))]) - #'(ellipses1 ellipses ... (wrapped x* ...) unwrap))))] - [(x ...) (with-syntax ([(x* ...) (map pull (syntax->list #'(x ...)))]) - (reverse-syntax #'(x* ...)))])))) - -;; (begin-for-syntax (trace pull)) (define-for-syntax (unpull stx) (define-syntax-class ellipses-class (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) (define-syntax-class delimiter-class (pattern x:id #:when (delimiter? #'x))) - ;; (debug "unpull ~a\n" (syntax->datum stx)) (syntax-parse stx #:literals (wrapped unwrap) [((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...) @@ -372,95 +176,9 @@ #'(x* ...))] [else stx])) -;; rename this to unwrap -#; -(define-syntax (unpull stx) - (define-syntax-class ellipses-class - (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) - (define (do-it stx) - (syntax-parse stx - #:literals (wrapped) - [((wrapped x ... y) ...) - (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))]) - #'(x1 ... y ...))] - [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...) - (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) - #'(x* ... ellipses1 ellipses ...))] - [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) - #'(x* ...))] - [else stx])) - (syntax-case stx () - [(_ x ...) (do-it #'(x ...))])) (provide (for-syntax unpull)) -#; -(define-honu-syntax unpull - (lambda (stx ctx) - (define-syntax-class ellipses-class - (pattern x:id #:when (free-identifier=? #'x #'(... ...)))) - (define (do-it stx) - (syntax-parse stx - #:literals (wrapped) - [((wrapped x ... y) ...) - (with-syntax ([(x1 ...) (car (syntax->list #'((x ...) ...)))]) - #'(x1 ... y ...))] - [((wrapped x ...) ellipses1:ellipses-class ellipses:ellipses-class ...) - (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) - #'(x* ... ellipses1 ellipses ...))] - [(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))]) - (debug "x* is ~a\n" #'(x* ...)) - #'(x* ...))] - [else stx])) - (syntax-case stx () - [(_ x ...) (values (do-it #'(x ...)) - #'())]))) - -#; -(define-syntax (test stx) - (syntax-case stx () - [(_ x ...) - (begin - (pretty-print (syntax->datum (pull #'(x ...)))) - (pretty-print (syntax->datum (unpull (pull #'(x ...))))) - #'1)])) - -(define-syntax (my-syntax stx) - (syntax-case stx () - [(_ name pattern template) - (with-syntax ([wrap-it (pull #'template)]) - #'(define-syntax (name stx) - (syntax-case stx () - [pattern #'wrap-it] - [else (raise-syntax-error 'name (format "~a does not match pattern ~a" - (syntax->datum stx) - 'pattern))] - )))])) - -#; -(define-syntax (honu-unparsed-expr stx) - (define (fix stx) - (debug "Fix ~a\n" (syntax->datum stx)) - (syntax-parse stx #:literals (honu-syntax #%parens) - [(honu-syntax (#%parens x ...) y ...) - (with-syntax ([(y* ...) (fix #'(y ...))]) - #'(x ... y* ...))] - [(z x ...) - (with-syntax ([z* (fix #'z)] - [(x* ...) (fix #'(x ...))]) - #'(z* x* ...))] - [else stx] - )) - (debug "unparsed expr ~a\n" stx) - (fix (stx-cdr stx))) - -(define-syntax (test2 stx) - (syntax-case stx () - [(_ x ...) - (begin - (with-syntax ([pulled (pull #'(x ...))]) - #'(unpull pulled)))])) - (define-honu-syntax honu-pattern (lambda (stx ctx) (syntax-parse stx #:literal-sets ([cruft #:at stx]) @@ -493,28 +211,11 @@ final-pattern))))) #'rest)]))) -(define foobar 0) - (define-honu-syntax honu-infix-macro (lambda (stx ctx) (debug "Infix macro!\n") (define-splicing-syntax-class patterns #:literal-sets ([cruft #:phase (syntax-local-phase-level)]) - #; - [pattern (~seq x ...) - #:with (template ...) '() - #:with (code ...) '() - #:with (fixed ...) '() - #:when (begin - (debug "Trying to parse ~a\n" (syntax->datum #'(x ...))) - #f)] - #; - [pattern (~seq (#%braces template ...) - (#%braces code ...)) - #:with (fixed ...) '() - #:when (begin - (debug "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...))) - #f)] [pattern (~seq (#%braces template ...) (#%braces code ...)) #:with (fixed ...) (fix-template #'(template ...))]) @@ -528,38 +229,19 @@ . rest) #:with result (list - (with-syntax ( - #; - [(fixed ...) (fix-template #'(template ...))] - #; - [first-pattern (stx-car #'(template ...))] - #; - [your-bracket (datum->syntax #'name '#%brackets #'name)] - #; - [your-braces (datum->syntax #'name '#%braces #'name)] - #; - [your-parens (datum->syntax #'name '#%parens #'name)]) + (with-syntax () (apply-scheme-syntax (syntax/loc stx (define-honu-infix-syntax name (lambda (stx ctx) - #; - (debug "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx)) (debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...)) (syntax-parse stx #:literal-sets ([cruft #:at name]) - #:literals (foobar literals ...) + #:literals (literals ...) [(pattern.fixed ... rrest (... ...)) (values - #; - (with-syntax ([(real-out (... ...)) #'(code ...)]) - (let ([result (let () - (honu-unparsed-begin #'(real-out (... ...))))]) - (lambda () result))) (begin (emit-remark "Do macro transformer" (quote-syntax (pattern.code ...))) - #; - (debug "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...)))) (let ([result (let () (honu-unparsed-begin pattern.code ...))]) (lambda () @@ -574,82 +256,14 @@ (syntax-parse stx [out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] - #; - [(_ (#%parens honu-literal ...) - (#%braces (#%braces name pattern ...)) - (#%braces (#%braces template ...)) - . rest) - (with-syntax ([pulled (pull #'(template ...))] - [(pattern* ...) (map (lambda (stx) - (if (and (identifier? stx) - (not (ormap (lambda (f) - (free-identifier=? stx f)) - (syntax->list #'(honu-literal ...)))) - (not (free-identifier=? stx #'(... ...)))) - (with-syntax ([x stx]) - #'(~and x (~not (~or honu-literal ...)))) - stx)) - (syntax->list #'(pattern ...)))] - ) - (values - (syntax/loc stx - (define-honu-syntax name - (lambda (stx ctx) - ;; (define-literal-set literals (honu-literal ...)) - (syntax-parse stx - ;; #:literal-sets (literals) - #:literals (honu-literal ...) - [(name pattern* ... . rrest) - (with-syntax ([(out (... ...)) (unpull #'pulled)]) - (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context")) - (values - (syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...))))) - ;; this is sort of ugly, is there a better way? - #; - (cond - [(type-context? ctx) (X)] - [(type-or-expression-context? ctx) (X)] - [(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))] - [(expression-block-context? ctx) - (syntax/loc stx - (honu-unparsed-begin (honu-syntax #%parens (out (... ...)))))] - [(block-context? ctx) - (syntax/loc stx - (honu-unparsed-begin out (... ...)))] - [(variable-definition-context? ctx) (X)] - [(constant-definition-context? ctx) (X)] - [(function-definition-context? ctx) (X)] - [(prototype-context? ctx) (X)] - [else (syntax/loc stx (honu-syntax (#%parens (out (... ...)))))]) - #; - #'(honu-unparsed-begin out (... ...)) - #'rrest) - #; - #'(honu-unparsed-block - #f obj 'obj #f ctx - out (... ...)) - #; - (values - #; - #'(honu-unparsed-expr out (... ...)) - #'(honu-unparsed-block - #f obj 'obj #f ctx - out (... ...) rrest) - #; - #'rrest))])))) - #'rest))] [(_ (m x ...) (z y ...) - #; - (#%braces (#%braces name pattern ...)) . rest) (begin (debug "Got literals ~a\n" #'(x ...)) (debug "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m)) (debug "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z)) (debug "Rest is ~a\n" (syntax->datum #'rest)) - #; - (debug "Got name ~a pattern ~a\n" #'name #'(pattern ...)) (raise-syntax-error 'honu-macro "f1" stx))] [else (raise-syntax-error 'honu-macro "fail" stx)] ))) @@ -658,21 +272,6 @@ (lambda (stx ctx) (define-splicing-syntax-class patterns #:literal-sets ([cruft #:phase (syntax-local-phase-level)]) - #; - [pattern (~seq x ...) - #:with (template ...) '() - #:with (code ...) '() - #:with (fixed ...) '() - #:when (begin - (debug "Trying to parse ~a\n" (syntax->datum #'(x ...))) - #f)] - #; - [pattern (~seq (#%braces template ...) - (#%braces code ...)) - #:with (fixed ...) '() - #:when (begin - (debug "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...))) - #f)] [pattern (~seq (#%braces template ...) (#%braces code ...)) #:with (fixed ...) (fix-template #'(template ...))]) @@ -686,54 +285,19 @@ . rest) #:with result (list - (with-syntax ( - #; - [(fixed ...) (fix-template #'(template ...))] - #; - [first-pattern (stx-car #'(template ...))] - #; - [your-bracket (datum->syntax #'name '#%brackets #'name)] - #; - [your-braces (datum->syntax #'name '#%braces #'name)] - #; - [your-parens (datum->syntax #'name '#%parens #'name)]) - ;;(debug "Ok macro3 go!\n") - #; - #'(define-honu-syntax name - (lambda (stx ctx) - (syntax-parse stx #:literals (your-parens your-bracket literals ...) - [(fixed ... rrest (... ...)) - (values - #; - (with-syntax ([(real-out (... ...)) #'(code ...)]) - (let ([result (honu-unparsed-begin #'(real-out (... ...)))]) - (lambda () result))) - (let ([result (honu-unparsed-begin code ...)]) - (lambda () result)) - #'(rrest (... ...)))]))) - #; - (debug "Original pattern ~a\n" (syntax->datum #'(pattern.fixed ... rrest (... ...)))) + (with-syntax () (apply-scheme-syntax (syntax/loc stx (define-honu-syntax name (lambda (stx ctx) - #; - (debug "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx)) (debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...)) (syntax-parse stx #:literal-sets ([cruft #:at name]) - #:literals (foobar literals ...) + #:literals (literals ...) [(pattern.fixed ... rrest (... ...)) (values - #; - (with-syntax ([(real-out (... ...)) #'(code ...)]) - (let ([result (let () - (honu-unparsed-begin #'(real-out (... ...))))]) - (lambda () result))) (begin (emit-remark "Do macro transformer" (quote-syntax (pattern.code ...))) - #; - (debug "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...)))) (let ([result (let () (honu-unparsed-begin pattern.code ...))]) (lambda () @@ -743,15 +307,6 @@ ... [else (raise-syntax-error 'name "bad syntax")] )))))) - #; - (with-syntax ([parsed (let-values ([(out rest*) - (parse-block-one/2 #'(code ...) - the-expression-context)]) - out)]) - (syntax/loc stx - (define-honu-syntax name - (lambda (stx ctx) - parsed)))) #'rest)]) (define-syntax-class honu-macro2 #:literals (#%parens #%braces) @@ -769,15 +324,6 @@ (syntax-parse stx #:literals (semicolon) [(_ semicolon rrest (... ...)) #'(rrest (... ...))])))))) - #; - (with-syntax ([parsed (let-values ([(out rest*) - (parse-block-one/2 #'(code ...) - the-expression-context)]) - out)]) - (syntax/loc stx - (define-honu-syntax name - (lambda (stx ctx) - parsed)))) #'rest)]) (define-syntax-class honu-macro1 @@ -812,39 +358,8 @@ (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context")) (values (syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...))))) - ;; this is sort of ugly, is there a better way? - #; - (cond - [(type-context? ctx) (X)] - [(type-or-expression-context? ctx) (X)] - [(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))] - [(expression-block-context? ctx) - (syntax/loc stx - (honu-unparsed-begin (honu-syntax #%parens (out (... ...)))))] - [(block-context? ctx) - (syntax/loc stx - (honu-unparsed-begin out (... ...)))] - [(variable-definition-context? ctx) (X)] - [(constant-definition-context? ctx) (X)] - [(function-definition-context? ctx) (X)] - [(prototype-context? ctx) (X)] - [else (syntax/loc stx (honu-syntax (#%parens (out (... ...)))))]) - #; - #'(honu-unparsed-begin out (... ...)) #'rrest) - #; - #'(honu-unparsed-block - #f obj 'obj #f ctx - out (... ...)) - #; - (values - #; - #'(honu-unparsed-expr out (... ...)) - #'(honu-unparsed-block - #f obj 'obj #f ctx - out (... ...) rrest) - #; - #'rrest))])))) + )])))) #'rest))]) (debug "Executing honu macro\n") (syntax-parse stx @@ -852,94 +367,14 @@ [out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] [out:honu-macro2 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))] - #; - [(_ (#%parens honu-literal ...) - (#%braces (#%braces name pattern ...)) - (#%braces (#%braces template ...)) - . rest) - (with-syntax ([pulled (pull #'(template ...))] - [(pattern* ...) (map (lambda (stx) - (if (and (identifier? stx) - (not (ormap (lambda (f) - (free-identifier=? stx f)) - (syntax->list #'(honu-literal ...)))) - (not (free-identifier=? stx #'(... ...)))) - (with-syntax ([x stx]) - #'(~and x (~not (~or honu-literal ...)))) - stx)) - (syntax->list #'(pattern ...)))] - ) - (values - (syntax/loc stx - (define-honu-syntax name - (lambda (stx ctx) - ;; (define-literal-set literals (honu-literal ...)) - (syntax-parse stx - ;; #:literal-sets (literals) - #:literals (honu-literal ...) - [(name pattern* ... . rrest) - (with-syntax ([(out (... ...)) (unpull #'pulled)]) - (define (X) (raise-syntax-error (syntax->datum #'name) "implement for this context")) - (values - (syntax/loc stx (honu-unparsed-expr (honu-syntax (#%parens out (... ...))))) - ;; this is sort of ugly, is there a better way? - #; - (cond - [(type-context? ctx) (X)] - [(type-or-expression-context? ctx) (X)] - [(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))] - [(expression-block-context? ctx) - (syntax/loc stx - (honu-unparsed-begin (honu-syntax #%parens (out (... ...)))))] - [(block-context? ctx) - (syntax/loc stx - (honu-unparsed-begin out (... ...)))] - [(variable-definition-context? ctx) (X)] - [(constant-definition-context? ctx) (X)] - [(function-definition-context? ctx) (X)] - [(prototype-context? ctx) (X)] - [else (syntax/loc stx (honu-syntax (#%parens (out (... ...)))))]) - #; - #'(honu-unparsed-begin out (... ...)) - #'rrest) - #; - #'(honu-unparsed-block - #f obj 'obj #f ctx - out (... ...)) - #; - (values - #; - #'(honu-unparsed-expr out (... ...)) - #'(honu-unparsed-block - #f obj 'obj #f ctx - out (... ...) rrest) - #; - #'rrest))])))) - #'rest))] [(_ (m x ...) (z y ...) - #; - (#%braces (#%braces name pattern ...)) . rest) (begin (debug "Got literals ~a\n" #'(x ...)) (debug "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m)) (debug "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z)) (debug "Rest is ~a\n" (syntax->datum #'rest)) - #; - (debug "Got name ~a pattern ~a\n" #'name #'(pattern ...)) (raise-syntax-error 'honu-macro "f1" stx))] [else (raise-syntax-error 'honu-macro "fail" stx)] ))) - -;; (my-syntax guz (_ display (#%parens x ...)) (+ x ...)) -;; (guz display (#%parens 1 2 3 4)) - -;; (local-expand stx 'expression (list #'wrapped)) - -#| -(begin-for-syntax - (trace pull)) -(test display (#%parens x)) -(test display (#%parens x ... ...) ...) -|# diff --git a/collects/honu/core/private/more.rkt b/collects/honu/core/private/more.rkt index 1c95b88c4b..a2188edc91 100644 --- a/collects/honu/core/private/more.rkt +++ b/collects/honu/core/private/more.rkt @@ -29,40 +29,23 @@ (datum->syntax lexical consed lexical)) (define (replace-commas stuff) - ;; (debug "Replace commas with: ~a\n" (syntax->datum stuff)) (syntax-parse stuff #:literals (ellipses-comma ellipses-comma*) [((ellipses-comma* z ...) thing blah ...) - #; - (debug "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...))) (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))]) (datum->syntax stuff #'(z ... honu-comma rest ...) ;; `(1 ,#'(z ...) ,#'honu-comma ,#'(rest ...)) - #; - (append (syntax->list #'(z ...)) (cons #'honu-comma #'(rest ...))) stuff - stuff) - #; - #'(z honu-comma rest ...))] + stuff))] [((ellipses-comma z) thing blah ...) - #; - (debug "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(thing blah ...))) (with-syntax ([(rest ...) (replace-commas #'(thing blah ...))]) - #; - (combine-syntax stuff #'z #'honu-comma #'(rest ...)) (datum->syntax stuff (cons #'z (cons #'honu-comma #'(rest ...))) stuff - stuff) - #; - #'(z honu-comma rest ...))] + stuff))] [(front (ellipses-comma* z ...) thing more ...) (with-syntax ([front* (replace-commas #'front)] [(rest* ...) (replace-commas #'(thing more ...))]) - (datum->syntax stuff #'(front z ... honu-comma rest* ...) stuff stuff) - #; - (datum->syntax stuff (cons #'front* (cons #'(z ...) (cons #'honu-comma #'(rest* ...)))) - stuff - stuff))] + (datum->syntax stuff #'(front z ... honu-comma rest* ...) stuff stuff))] [(front (ellipses-comma z) thing more ...) (define (maybe-apply-raw stx) (syntax-parse stuff #:literals (ellipses-comma) @@ -75,35 +58,14 @@ (datum->syntax stuff (cons #'front* (cons #'z (cons #'honu-comma #'(rest* ...)))) stuff stuff))] - #; - [(front (ellipses-comma (z ...)) thing more ...) - (define (maybe-apply-raw stx) - (syntax-parse stuff #:literals (ellipses-comma) - [(front (ellipses-comma x) . rest) - (if (raw-scheme? #'x) - (apply-scheme-syntax stx) - stx)])) - (with-syntax ([front* (replace-commas #'front)] - [(rest* ...) (replace-commas #'(thing more ...))]) - (datum->syntax stuff (cons #'front* - (cons (datum->syntax stuff #'(z ...) stuff stuff) - (cons #'honu-comma #'(rest* ...)))) - stuff - stuff))] - #; - [((ellipses-comma (z ...))) (datum->syntax stuff #'(z ...) stuff stuff)] [((ellipses-comma* z ...)) (datum->syntax stuff #'(z ...) stuff stuff)] [((ellipses-comma z)) (datum->syntax stuff #'(z) stuff stuff)] [(z rest ...) (with-syntax ([z* (replace-commas #'z)] [(rest* ...) (replace-commas #'(rest ...))]) - #; - (combine-syntax stuff #'z #'(rest* ...)) (datum->syntax stuff (cons #'z* #'(rest* ...)) - stuff stuff) - #; - #'(z* rest* ...))] + stuff stuff))] [else stuff])) ;; (trace replace-commas) @@ -128,9 +90,7 @@ [(rest* ...) (fix #'(rest ...))]) (datum->syntax stuff (cons #'one* #'(rest* ...)) - stuff stuff) - #; - #'(one* rest* ...))] + stuff stuff))] [else stuff])) (define (replace2 stuff) (syntax-parse stuff #:literals (ellipses-comma ellipses-repeat #%parens) @@ -142,9 +102,7 @@ (cons #'(... ...) #'(rest* ...))) - stuff stuff)) - #; - #'((ellipses-comma a*) (... ...) rest* ...)] + stuff stuff))] [(a ellipses-comma rest ...) (with-syntax ([a* (replace #'a)] [(rest* ...) (replace #'(rest ...))]) @@ -154,31 +112,16 @@ (cons #'(... ...) #'(rest* ...))) - stuff stuff) - #; - #'((ellipses-comma a*) (... ...) rest* ...))] + stuff stuff))] [(z rest ...) (with-syntax ([z* (replace #'z)] [(rest* ...) (replace #'(rest ...))]) (datum->syntax stuff (cons #'z* #'(rest* ...)) - stuff stuff) - #; - #'(z* rest* ...))] + stuff stuff))] [else stuff])) (define (replace stuff) - #| - (debug "Replacing ~a\n" (syntax->datum stuff)) - (debug "Local phase level ~a\n" (syntax-local-phase-level)) - (debug "Checking..\n") - (syntax-parse stuff - [(a b c rest ...) - (debug "a: ~a\n" #'a) - (debug "b: ~a identifier ~a = , is ~a. honu-comma at ~a\n" #'b (identifier? #'b) (and (identifier? #'b) (free-identifier=? #'b #'honu-comma)) (identifier-binding #'honu-comma)) - (debug "c: ~a = ... is ~a\n" #'c (and (identifier? #'c) (free-identifier=? #'c #'(... ...))))] - [else (void)]) - |# (syntax-parse stuff #:literals (;; honu-comma ;; FIXME! Use a literal-set and #:at instead of this @@ -211,9 +154,7 @@ (with-syntax ([out2 replaced]) (let ([x #'(apply-scheme-syntax (replace-commas #'out2))]) (debug "Final syntax ~a\n" (syntax->datum x)) - x)))] - #; - [(_ blah ...) (fix #'(blah ...))])) + x)))])) (define-syntax-rule (honu-syntax-maker maker unparsed) (define-honu-syntax maker @@ -228,129 +169,12 @@ [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))] [else (debug "~a is *not* a pattern variable\n" what)])) - #; - (debug "Original code is ~a\n" (syntax->datum #'(expr ...))) - #; - (debug "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...)))) - #; - (for-each show-pattern-variables (syntax->list #'(expr ...))) - ;; outer is relative phase 1, inner is relative phase 0 - #| - #'#'(honu-unparsed-begin expr ...) - |# - - #; - (syntax (fix-template (syntax (honu-unparsed-begin expr ...)))) - - #; - (with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))]) - #'a) - (debug "Making unparsed syntax with `~a'\n" (syntax->datum #'(expr (... ...)))) - #; - (with-syntax ([unparsed (make-unparsed #'(expr ...))]) - #'(fix-template unparsed)) - - #; - (datum->syntax stx - (cons #'fix-template - (cons #'unparsed #'(expr (... ...)))) - stx stx) - - #; - (let ([original #'(expr (... ...))]) - (datum->syntax original - (cons #'fix-template - (cons #'unparsed #'(expr (... ...)))) - original original)) - - #'(fix-template (unparsed expr (... ...))) - - #; - #'(fix-template (expr ...)) - - #; - (apply-scheme-syntax #'(fix-template (expr ...))) - - #; - (let ([x #'(fix-template (honu-unparsed-begin expr ...))]) - (debug "Final syntax ~a\n" (syntax->datum x)) - x) - - #; - #'(fix-template 1 2 3) - - #; - (with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())]) - #'(honu-unparsed-begin out ...))) + #'(fix-template (unparsed expr (... ...)))) #'rest)] [else (raise-syntax-error 'maker "you have used this incorrectly")] )))) (honu-syntax-maker honu-syntax honu-unparsed-begin) (honu-syntax-maker honu-expression-syntax honu-unparsed-expr) - -#; -(define-honu-syntax honu-syntax - (lambda (stx ctx) - (syntax-parse stx #:literals (semicolon #%parens) - [(_ (#%parens expr ...) semicolon . rest) - (values - (lambda () - (define (show-pattern-variables what) - (cond - [(syntax-pattern-variable? what) (debug "~a is a pattern variable\n") what] - [(stx-pair? what) (for-each show-pattern-variables (syntax->list what))] - [else (debug "~a is *not* a pattern variable\n" what)])) - - (define (make-unparsed code) - (debug "Make unparsed in ~a. expression-context? ~a\n" ctx (expression-context? ctx)) - (with-syntax ([(code ...) code]) - (cond - [(expression-context? ctx) - (syntax/loc stx (honu-unparsed-expr code ...))] - [else #'(honu-unparsed-begin code ...)]))) - - #; - (debug "Original code is ~a\n" (syntax->datum #'(expr ...))) - #; - (debug "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(expr ...)))) - #; - (for-each show-pattern-variables (syntax->list #'(expr ...))) - ;; outer is relative phase 1, inner is relative phase 0 - #| - #'#'(honu-unparsed-begin expr ...) - |# - - #; - (syntax (fix-template (syntax (honu-unparsed-begin expr ...)))) - - #; - (with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))]) - #'a) - - (debug "Making unparsed syntax???\n") - (with-syntax ([unparsed (make-unparsed #'(expr ...))]) - #'(fix-template unparsed)) - - ;; #'(fix-template (honu-unparsed-begin expr ...)) - - #; - #'(fix-template (expr ...)) - - #; - (apply-scheme-syntax #'(fix-template (expr ...))) - - #; - (let ([x #'(fix-template (honu-unparsed-begin expr ...))]) - (debug "Final syntax ~a\n" (syntax->datum x)) - x) - - #; - #'(fix-template 1 2 3) - - #; - (with-syntax ([(out ...) (local-expand #'(expr ...) 'expression '())]) - #'(honu-unparsed-begin out ...))) - #'rest)]))) diff --git a/collects/honu/core/private/mzscheme.rkt b/collects/honu/core/private/mzscheme.rkt deleted file mode 100644 index 112a1e2964..0000000000 --- a/collects/honu/core/private/mzscheme.rkt +++ /dev/null @@ -1,3 +0,0 @@ -(module mzscheme mzscheme - (provide (all-from-except mzscheme - string))) diff --git a/collects/honu/core/private/parse.rkt b/collects/honu/core/private/parse.rkt index 85d94057fc..f07a1b09de 100644 --- a/collects/honu/core/private/parse.rkt +++ b/collects/honu/core/private/parse.rkt @@ -27,13 +27,6 @@ (provide (all-defined-out)) -#; -(begin-for-syntax - (current-failure-handler - (lambda (_ f) - (debug "Failure is ~a\n" (failure->sexpr (simplify-failure f))) - (error 'failed "whatever")))) - (define-syntax-class block #:literals (#%braces) [pattern (#%braces statement ...) @@ -47,18 +40,7 @@ body.result)]) (define (syntax-object-position mstart end) - (- (length (syntax->list mstart)) (length (syntax->list end))) - #; - (if (stx-null? end) - (length (syntax->list mstart)) - (let loop ([start mstart] - [count 0]) - ;; (debug "Checking ~a vs ~a\n" start end) - (cond - [(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)] - [(equal? (stx-car start) (stx-car end)) count] - ;; [(equal? start end) count] - [else (loop (stx-cdr start) (add1 count))])))) + (- (length (syntax->list mstart)) (length (syntax->list end)))) (define-primitive-splicing-syntax-class (infix-macro-class left-expression context) #:attributes (result) @@ -87,20 +69,6 @@ (debug "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx)) (cond [(stx-null? stx) (fail)] - #; - [(syntax-parse stx #:literals (honu-syntax #%parens semicolon) - [(honu-syntax (#%parens expr ...) semicolon . rest) - (debug "Parsed honu-syntax rest ~a position ~a out ~a\n" - #'rest (syntax-object-position stx #'rest) - #'(honu-unparsed-begin expr ...)) - (list (syntax-object-position stx #'rest) - #'(honu-unparsed-begin expr ...))] - [else #f] - #; - [else #f => (lambda (exprs) - (debug "Ignoring honu-syntax 1!\n") - (list 0 #''()))] - )] [(get-transformer stx) => (lambda (transformer) (define introducer (make-syntax-introducer)) (debug "Transforming honu macro ~a\n" (stx-car stx)) @@ -109,9 +77,7 @@ (debug "Result is ~a. Object position is ~a out of expression ~a\n\n" used (syntax-object-position stx (introducer rest)) (syntax->datum stx)) (debug "Used is ~a\n" (syntax->datum (introducer (used)))) (list (syntax-object-position stx (introducer rest)) - (list #f) - #; - (introducer (used)))))] + (list #f))))] [else (fail)]))) @@ -122,23 +88,6 @@ (debug "Honu expr ~a\n" stx) (cond [(stx-null? stx) (fail)] - #; - [(syntax-parse stx #:literals (honu-syntax #%parens semicolon) - [(honu-syntax (#%parens expr ...) semicolon . rest) - (list #'rest (syntax-object-position stx #'rest) - #'(honu-unparsed-begin expr ...))] - [else #f] - #; - [else #f => (lambda (exprs) - (debug "Ignoring honu-syntax 1!\n") - (list 0 #''()))] - )] - #; - [(syntax-parse stx #:literals (honu-syntax) - [(honu-syntax expr ...) #'(expr ...)] - [else #f]) => (lambda (exprs) - (debug "Ignoring honu-syntax 2!\n") - (list '() 0 exprs))] [(get-transformer stx) => (lambda (transformer) (define introducer (make-syntax-introducer)) (debug "Transforming honu macro ~a\n" (car stx)) @@ -149,24 +98,10 @@ [else (syntax-case stx () [(f . rest) (list 1 #'f)])]))) - - #; - (define-splicing-syntax-class expr - [pattern (~seq f ...) #:with result]) (define-splicing-syntax-class (call context) #:literals (honu-comma #%parens) - #; - [pattern (~seq (~var e identifier) - (x (~var arg (expression-1 context)) ...) - #; - (#%parens (~var arg (expression-1 context)) ...)) - #:with call - (begin - (debug "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...))) - #'(e.x arg.result ...))] - [pattern (~seq (~var e honu-identifier) (#%parens rest ...)) #:with call #f #:when (begin (debug "Trying a call on ~a and ~a\n" #'e #'(rest ...)) @@ -183,38 +118,18 @@ #:with call (begin (debug "Resulting call is ~a\n" (syntax->datum #'(e.result arg.result ...))) - #'(e.result arg.result ...))] - - #; - [pattern (~seq (~var e honu-identifier - #; - (honu-expr context)) - (~var d1 (debug-here (format "call 1 ~a\n" #'e))) - (x - (~var d2 (debug-here (format "call 2 ~a\n" #'x))) - ;;#%parens - (~seq (~var arg (ternary context)) - (~var d3 (debug-here (format "call 3 ~a\n" #'arg))) - (~optional honu-comma)) - ...)) - #:with call - (begin - (debug "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...))) - #'(e.x arg.result ...))]) + #'(e.result arg.result ...))]) (define-splicing-syntax-class honu-identifier [pattern (~seq x:identifier) #:when (not (or (free-identifier=? #'honu-comma #'x) - (free-identifier=? #'semicolon #'x)) - ) + (free-identifier=? #'semicolon #'x))) #:with result #'x]) (define-splicing-syntax-class (expression-simple context) #:literals (#%parens) [pattern (~seq (#%parens (~var e (expression-1 context)))) #:with result #'e.result] [pattern (~seq (~var e (honu-transformer - the-expression-context - #; - context))) #:with result #'e.result] + the-expression-context))) #:with result #'e.result] [pattern (~seq x:number) #:with result (begin (debug "got a number ~a\n" #'x) #'x)] [pattern (~seq x:str) #:with result #'x] [pattern (~seq x:honu-identifier) #:with result #'x.x]) @@ -222,17 +137,9 @@ (define-splicing-syntax-class (expression-last context) #:literals (#%parens honu-:) - #; - [pattern (~seq a 1 2 3 b 4 5 6)] - [pattern (~seq x) #:with result #f #:when (begin (debug "Expression last ~a. Raw? ~a\n" #'x (raw-scheme? #'x)) #f)] - [pattern (~seq raw:raw-scheme-syntax) #:with result #'raw.x - #; - (begin (debug "raw syntax ~a\n" #'raw) - (if (stx-pair? #'raw) - (stx-car #'raw) - #'raw))] + [pattern (~seq raw:raw-scheme-syntax) #:with result #'raw.x] [pattern (~seq (#%braces code:statement)) #:with result #'(begin code.result)] @@ -240,18 +147,13 @@ [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 - the-expression-context - #; - context))) + the-expression-context))) #:with result #'e.result #:with rest #'e.rest] [pattern (~seq x:number) #:with result (begin (debug "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] - #; - [pattern (~seq (~var e (honu-expr context))) #:with result #'e.result] - ) + [pattern (~seq x:honu-identifier) #:with result #'x.x]) (define-syntax-rule (define-infix-operator name next [operator reducer] ...) (begin @@ -267,37 +169,15 @@ #:with result (begin (debug "Left was ~a\n" left) - #; - (attribute new-right.result) (apply-scheme-syntax (attribute new-right.result)))) - (pattern (~seq) #:with result (begin #;(debug "Left is still ~a\n" left) - left))) + (pattern (~seq) #:with result left)) (define-splicing-syntax-class (name context) (pattern (~seq (~var left2 (next context)) (~var rest (do-rest context (attribute left2.result)))) #:with result - (attribute rest.result))) - #; - (define-splicing-syntax-class (name context) - (pattern (~seq (~var left (next context)) - (~var op operator-class) - (~var right (name context))) - #:with result - (cond [(attribute right) - ((attribute op.func) #'left.result #'right.result)] - [else - #'left.result])) - - #; - (pattern (~seq (~var left (next context)) - (~optional (~seq (~var op operator-class) (~var right (name context))))) - #:with result - (cond [(attribute right) - ((attribute op.func) #'left.result #'right.result)] - [else - #'left.result]))))) + (attribute rest.result))))) @@ -376,9 +256,7 @@ (define-splicing-syntax-class (ternary context) #:literals (honu-? honu-:) [pattern (~seq (~var condition - (infix-macro context) - #; - (expression-1 context)) + (infix-macro context)) (~var x1 (debug-here (format "ternary 1 ~a\n" (syntax->datum #'condition.result)))) (~optional (~seq honu-? (~var on-true (ternary context)) honu-: (~var on-false (ternary context)))) @@ -423,12 +301,7 @@ #:with rest #'assignment.rest] [pattern ((#%braces stuff ...) . rest) #:with result - (do-parse-block #'(stuff ...)) - #; - (let-values ([(parsed dont-care) - (parse-block-one/2 #'(stuff ...) context)]) - (debug "Parsed ~a. Dont care rest ~a\n" parsed dont-care) - parsed)] + (do-parse-block #'(stuff ...))] [pattern ((~var x0 (debug-here (format "expression top\n"))) (~var e (ternary context)) (~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e)))) @@ -474,154 +347,28 @@ proc)) (make-honu-infix-trans proc)) -#; -(define-honu-syntax honu-scheme - (lambda (stx ctx) - (syntax-parse stx - [(_ template rest ...) (values #'template #'(rest ...))]))) - -(define (fix-output stx) - #f - #| - (debug "Fix output ~a\n" (syntax->datum stx)) - (when (and (stx-pair? stx) (equal? 'honu-syntax (syntax->datum (stx-car stx)))) - (debug "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax))) - (when (identifier? stx) - (debug "Current phase ~a stx at ~a honu-scheme ~a same? ~a\n" (syntax-local-phase-level) (identifier-binding stx) - (identifier-transformer-binding #'honu-scheme) - (free-identifier=? stx #'honu-scheme) - )) - |# - #; - (syntax-parse stx #:literals (honu-syntax #%parens syntax) - #; - [((honu-syntax (#%parens x ...) y ...) rest ...) - #; - (debug "a1\n") - (with-syntax ([(y* ...) (fix-output #'(y ... rest ...))]) - (syntax/loc stx - ((honu-syntax x ...) y* ...)))] - #; - [(start ... (honu-scheme code ...) rest ...) - (with-syntax ([(rest* ...) (fix-output #'(rest ...))]) - (syntax/loc stx - (start ... honu-scheme (code ...) rest* ...)))] - #; - [(honu-syntax (#%parens x ...) y ...) - #; - (debug "a2\n") - (with-syntax ([(y* ...) (fix-output #'(y ...))]) - (syntax/loc stx - (x ... y* ...)))] - ;; dont touch real syntax - [(syntax stuff ...) - #; - (debug " aa\n") - stx] - #; - [honu-scheme (raise-syntax-error 'asdfioj "got honu-scheme")] - [(z x ...) - #; - (debug "a3\n") - (datum->syntax stx (cons (fix-output #'z) - (fix-output #'(x ...))) - stx) - - #; - (with-syntax ([z* (fix-output #'z)] - [(x* ...) (fix-output #'(x ...))]) - (syntax/loc stx - (z* x* ...)))] - #; - [(honu-syntax . rest) - (raise-syntax-error 'fix-output "invalid use of honu-syntax")] - [else - #; - (debug " no change\n") - stx])) - (define-splicing-syntax-class expression [pattern (~seq (~var x (expression-1 the-expression-context))) #:with result (apply-scheme-syntax #'x.result)]) -(define-splicing-syntax-class (whats-here? hm) - [pattern (~seq x ...) - #:when (begin (debug "Whats at `~a': `~a'\n" hm (syntax->datum #'(x ...))) - #f)]) - -#; -(define-syntax-class statement - [pattern ((~var f (whats-here? "statement1")) - (~var x (expression-top the-top-block-context))) - #:with result (apply-scheme-syntax (attribute x.result)) - #:with rest #'x.rest]) - (define-splicing-syntax-class statement #:literals (semicolon) - [pattern (~seq (~var x (ternary the-top-block-context)) - (~var q (debug-here "statement 2")) - #; - (~var qq (whats-here? "statement 2.1")) - (~var z (debug-here "statement 3")) - ) + [pattern (~seq (~var x (ternary the-top-block-context))) #: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))) - #:with result (apply-scheme-syntax (attribute x.result)) - #:with rest #'x.rest] - - #; - [pattern (~seq (~var f (whats-here? "statement1")) - (~var f1 (whats-here? "statement2")) - (~seq - (~var x (expression-top the-top-block-context)))) - #:with result (apply-scheme-syntax (attribute x.result)) - #:with rest #'x.rest]) - -#; -(define-splicing-syntax-class statement - [pattern (~seq - (~optional (~var zz (whats-here? "statement"))) - (~var d1 (debug-here (format "statement 1\n"))) - (~var x (expression-top the-top-block-context)) - (~var d2 (debug-here (format "statement 2\n"))) - ) - #:with result (apply-scheme-syntax #'x.result) #:with rest #'x.rest]) (define-splicing-syntax-class expression-comma #:literals (honu-comma) - #; - [pattern ;; ((~seq x) ...) - (x ...) - #:with (expr ...) (filter (lambda (n) - (not (free-identifier=? #'honu-comma n))) - (syntax->list #'(x ...)))] - #; - [pattern ((~seq (~var expr honu-identifier) (~optional honu-comma)) ...)] - - #; - [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)]) (define (parse-an-expr stx) (debug "Parse an expr ~a\n" (syntax->datum stx)) (syntax-parse (with-syntax ([(s ...) stx]) #'(s ...)) - #; - [(raw:raw-scheme-syntax . rest) #'raw] [((~var expr (expression-1 the-expression-context)) . rest) #'expr.result] - [else (raise-syntax-error 'parse-an-expr "cant parse" stx)] - )) + [else (raise-syntax-error 'parse-an-expr "can't parse" stx)])) (define-splicing-syntax-class honu-body:class #:literals (#%braces) @@ -629,93 +376,12 @@ (define (parse-block-one/2 stx context) (define (parse-one stx context) - #; - (let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))]) - (debug "debug parse for ~a is ~a and ~a\n" 'SQL_create_insert a b)) - #; - (let-values ([(a b) (debug-parse stx ((~seq (~var x (expression-top context)))))]) - (debug "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b)) - - ;; (debug "~a\n" (syntax-class-parse function stx)) (syntax-parse stx - #; - [(raw:raw-scheme-syntax . rest) (values #'raw #'rest)] - #; - [function:function (values #'function.result #'function.rest)] - [(~var expr (expression-top context)) (values #'expr.result #'expr.rest)] - #; - [(x:number . rest) (values #'x #'rest)] - )) + [(~var expr (expression-top context)) (values #'expr.result #'expr.rest)])) (debug "Parsing ~a\n" (syntax->datum stx)) (cond [(stx-null? stx) (values stx '())] - #; - [(syntax-parse stx #:literals (honu-syntax #%parens semicolon) - [(honu-syntax (#%parens expr ...) semicolon . rest) - (list #'(expr ...) - #'rest) - #; - (debug "Parsed honu-syntax rest ~a position ~a out ~a\n" - #'rest (syntax-object-position stx #'rest) - #'(honu-unparsed-begin expr ...)) - #; - (list #'rest (syntax-object-position stx #'rest) - #'(honu-unparsed-begin expr ...))] - [else #f] - #; - [else #f => (lambda (exprs) - (debug "Ignoring honu-syntax 1!\n") - (list 0 #''()))] - ) => (lambda (all) - (let ([to-parse (car all)] - [rest (cadr all)]) - (let-values ([(out rest2) - (with-syntax ([(more ...) rest] - [(stuff ...) to-parse]) - (parse-block-one/2 #'(stuff ... more ...) context))]) - (values out rest2)))) - ] - #; - [(get-transformer stx) => (lambda (transformer) - (define introducer (make-syntax-introducer)) - (define introduce introducer) - (define unintroduce introducer) - #; - (define introduce (compose introducer syntax-local-introduce)) - #; - (define unintroduce (compose syntax-local-introduce introducer)) - (debug "Parse one: execute transformer ~a ~a\n" (stx-car stx) transformer) - #; - (debug "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b))) - (let-values ([(output rest) - (transformer (introduce stx) context)]) - (values (unintroduce (output)) (unintroduce rest))) - #; - (call-values (transformer stx context) - (lambda (reparse rest) - ;; (define fixed (fix-output reparse)) - (define fixed reparse) - (debug "Transformer gave us ~a\n" (syntax->datum reparse)) - #; - (values reparse rest) - #; - (values (fix-output reparse) rest) - #; - (debug "Macroized ~a and ~a\n" reparse rest) - (debug "Fixed syntax ~a\n" (syntax->datum fixed)) - (syntax-parse fixed #:literals (honu-unparsed-expr) - [(honu-unparsed-expr stuff ...) - (let-values ([(out rest2) - (with-syntax ([(more ...) rest]) - (parse-block-one/2 #'(stuff ... more ...) context))]) - (values out rest2))] - [else (values fixed rest)])) - ))] - [else (parse-one stx context)] - #; - [else (let-values ([(a b) (parse-one stx context)]) - (values (apply-scheme-syntax a) b))] - )) + [else (parse-one stx context)])) (define operator? (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) @@ -767,29 +433,7 @@ (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) (and (honu-transformer? v) v))] [else #f])))) - #; - (debug "~a bound transformer? ~a at phase level ~a identifiers: ~a\n" stx (bound-transformer stx) (syntax-local-phase-level) - (if (and (stx-pair? stx) - (identifier? (stx-car stx))) - (let ([id (stx-car stx)]) - (for/list ([phase (in-range -2 2)]) - (format "~a : ~a." phase (identifier-binding id phase)))) - 'not-an-id)) - (bound-transformer stx) - #; - (or (bound-transformer stx) - (special-transformer stx))) - -#; -(define-honu-syntax honu-syntax - (lambda (stx ctx) - (syntax-case stx () - [(_ expr ...) - (begin - (debug "Honu syntax on ~a\n" #'(expr ...)) - (raise-syntax-error 'honu-syntax "should have been handled already") - #; - (parse-block-one/2 #'(expr ...) the-expression-context))]))) + (bound-transformer stx)) (define (do-parse-block block) (define parsed @@ -802,6 +446,3 @@ rest*))))) (with-syntax ([(out ...) (reverse parsed)]) #'(begin out ...))) - -(define (cheetos) 1) -; (define cheetos "foo") diff --git a/collects/honu/core/private/syntax.rkt b/collects/honu/core/private/syntax.rkt index f8ec079471..249d61a9bb 100644 --- a/collects/honu/core/private/syntax.rkt +++ b/collects/honu/core/private/syntax.rkt @@ -2,40 +2,10 @@ (provide (all-defined-out)) -#; -(define-syntax (honu-syntax stx) - (syntax-case stx () - [(_ expr) - #'(honu-unparsed-expr expr) - #; - (begin - (debug "honu syntax ~a\n" stx) - (raise-syntax-error 'honu-syntax "dont call this") - #'(make-honu-transformer (lambda (stx ctx) - (debug "honu syntax ~a\n" stx) - #'(expr ...))))])) - -#; -(define-syntax honu-unparsed-expr - (lambda (stx) (raise-syntax-error 'honu-unparsed-expr "dont use this"))) - (define honu-scheme-syntax 'honu-scheme-syntax) -#; -(define honu-scheme-syntax (gensym)) - -#; -(define-syntax-rule (scheme-syntax stx) - (syntax-property (syntax stx) honu-scheme-syntax #t)) - (define (raw-scheme? stx) (syntax-property stx honu-scheme-syntax)) (define (apply-scheme-syntax stx) (syntax-property stx honu-scheme-syntax #t)) - -#; -(define-syntax (scheme-syntax stx) - (syntax-case stx () - [(_ x ...) - (lambda () '(syntax-property #'(x ...) honu-scheme-syntax #t))])) diff --git a/collects/honu/core/private/util.rkt b/collects/honu/core/private/util.rkt index 9f43ac19f9..d6e45b9e05 100644 --- a/collects/honu/core/private/util.rkt +++ b/collects/honu/core/private/util.rkt @@ -8,11 +8,6 @@ syntax/stx racket/list) -#; -(provide delim-identifier=? - extract-until - call-values) - (define (delim-identifier=? a b) (eq? (syntax-e a) (syntax-e b))) @@ -74,9 +69,6 @@ (debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit)) )))) -#; -(test) - ;; better version of caddadadr-type functions (define-syntax (list-match stx) (define (convert-pattern pattern) @@ -103,12 +95,3 @@ [match-variable (extract-variable #'pattern)]) #'(match expression [match-pattern match-variable]))])) - -#; -(test - (list-match a '(1 2 3)) => '(1 2 3) - (list-match (a _ ...) '(1 2 3)) => 1 - (list-match (_ _ a ...) '(1 2 3 4)) => '(3 4) - (list-match ((_ a _ ...) _ ...) '((1 2 3 4) 5 6)) => 2 - (list-match ((_ _ a _ ...) _ ...) '((7 6 5 4 3 2 1) 8 9)) => 5 - )