change printf to debug. add infix macro parser
This commit is contained in:
Jon Rafkind
parent
c45aba592d
commit
1b356476a4
|
|
@ -161,6 +161,7 @@
|
|||
(honu-provide provide)
|
||||
(honu-macro-item macroItem)
|
||||
(honu-macro macro)
|
||||
(honu-infix-macro infixMacro)
|
||||
(honu-identifier identifier)
|
||||
(honu-identifier identifier123)
|
||||
(honu-require require)
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(provide debug)
|
||||
|
||||
(define-for-syntax verbose? #t)
|
||||
(define-for-syntax verbose? #f)
|
||||
(define-syntax (debug stx)
|
||||
(if verbose?
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -9,19 +9,21 @@
|
|||
syntax/parse/experimental/splicing
|
||||
scheme/splicing
|
||||
macro-debugger/emit
|
||||
"contexts.ss"
|
||||
"util.ss"
|
||||
"ops.ss"
|
||||
"syntax.ss"
|
||||
"parse.ss"
|
||||
"literals.ss"
|
||||
"debug.rkt"
|
||||
"contexts.rkt"
|
||||
"util.rkt"
|
||||
"ops.rkt"
|
||||
"syntax.rkt"
|
||||
"parse.rkt"
|
||||
"literals.rkt"
|
||||
)
|
||||
syntax/parse
|
||||
"literals.ss"
|
||||
"literals.rkt"
|
||||
"debug.rkt"
|
||||
;; "typed-utils.ss"
|
||||
)
|
||||
|
||||
(require (for-meta 2 scheme/base "util.ss"))
|
||||
(require (for-meta 2 scheme/base "util.rkt"))
|
||||
(require (for-meta 3 scheme/base))
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
|
@ -262,7 +264,7 @@
|
|||
(with-syntax ([top-expr (if (top-block-context? context)
|
||||
#'(let ([v code])
|
||||
(unless (void? v)
|
||||
(printf "~s\n" v)))
|
||||
(debug "~s\n" v)))
|
||||
#'code)])
|
||||
(combine-k #'(#%expression top-expr)
|
||||
(stx-cdr after-expr))))))
|
||||
|
|
@ -324,6 +326,13 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
|
|||
(syntax/loc stx
|
||||
(define-syntax id (make-honu-transformer rhs))))))
|
||||
|
||||
(define-syntax (define-honu-infix-syntax stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
|
||||
(with-syntax ([id id]
|
||||
[rhs rhs])
|
||||
(syntax/loc stx
|
||||
(define-syntax id (make-honu-infix-transformer rhs))))))
|
||||
|
||||
#;
|
||||
(define-honu-syntax honu-provide
|
||||
(lambda (stx ctx)
|
||||
|
|
@ -366,7 +375,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
|
|||
(define-honu-syntax honu-if
|
||||
(lambda (stx ctx)
|
||||
(define (parse-complete-block stx)
|
||||
;; (printf "Parsing complete block ~a\n" (syntax->datum stx))
|
||||
;; (debug "Parsing complete block ~a\n" (syntax->datum stx))
|
||||
(with-syntax ([(exprs ...) (parse-block stx the-expression-block-context)])
|
||||
#'(begin exprs ...))
|
||||
#;
|
||||
|
|
@ -383,7 +392,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
|
|||
#f
|
||||
"expected a braced block or a statement"
|
||||
)))])
|
||||
(printf "Result is ~a and ~a\n" a b)
|
||||
(debug "Result is ~a and ~a\n" a b)
|
||||
a))
|
||||
;; TODO: move these syntax classes to a module
|
||||
(define-syntax-class expr
|
||||
|
|
@ -396,12 +405,12 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
|
|||
#:with line #'(honu-unparsed-begin statement ...)
|
||||
#;
|
||||
(parse-complete-block #'(statement ...))])
|
||||
;; (printf "Original syntax ~a\n" (syntax->datum stx))
|
||||
;; (debug "Original syntax ~a\n" (syntax->datum stx))
|
||||
(syntax-parse stx
|
||||
#:literals (else)
|
||||
[(_ condition:paren-expr on-true:block else on-false:block . rest)
|
||||
;; (printf "Condition expr is ~a\n" #'condition.expr)
|
||||
;; (printf "used if with else\n")
|
||||
;; (debug "Condition expr is ~a\n" #'condition.expr)
|
||||
;; (debug "used if with else\n")
|
||||
(let ([result #'(if condition.result on-true.line on-false.line)])
|
||||
(values
|
||||
(lambda () result)
|
||||
|
|
@ -409,7 +418,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
|
|||
#;
|
||||
(expression-result ctx result (syntax/loc #'rest rest)))]
|
||||
[(_ condition:paren-expr on-true:block . rest)
|
||||
;; (printf "used if with no else\n")
|
||||
;; (debug "used if with no else\n")
|
||||
(let ([result #'(when condition.result on-true.line)])
|
||||
(values
|
||||
(lambda () result)
|
||||
|
|
@ -485,7 +494,7 @@ if (foo){
|
|||
|
||||
(define (show-top-result v)
|
||||
(unless (void? v)
|
||||
(printf "~s\n" v)))
|
||||
(debug "~s\n" v)))
|
||||
|
||||
(define-syntax (op-app stx)
|
||||
(syntax-case stx (#%parens #%angles)
|
||||
|
|
@ -501,16 +510,16 @@ if (foo){
|
|||
#'a)]))
|
||||
|
||||
(define-syntax (honu-top stx)
|
||||
(printf "Honu ~a\n" (syntax->datum stx))
|
||||
(debug "Honu ~a\n" (syntax->datum stx))
|
||||
(raise-syntax-error #f "interactive use is not yet supported"))
|
||||
|
||||
(define-syntax (foobar2000 stx)
|
||||
(printf "Called foobar2000 on ~a\n" (syntax->datum stx))
|
||||
(debug "Called foobar2000 on ~a\n" (syntax->datum stx))
|
||||
(syntax-case stx ()
|
||||
[(_ x y ...) #'(printf "foobar2000 ~a\n" x)]))
|
||||
[(_ x y ...) #'(debug "foobar2000 ~a\n" x)]))
|
||||
|
||||
(define (display2 x y)
|
||||
(printf "~a ~a" x y))
|
||||
(debug "~a ~a" x y))
|
||||
|
||||
(define-syntax (honu-unparsed-expr stx)
|
||||
(syntax-parse stx
|
||||
|
|
@ -525,7 +534,7 @@ if (foo){
|
|||
[(_ template . rest)
|
||||
(values
|
||||
(lambda ()
|
||||
(printf "Applying syntax to ~a\n" (quote-syntax template))
|
||||
(debug "Applying syntax to ~a\n" (quote-syntax template))
|
||||
(apply-scheme-syntax #'#'template))
|
||||
#'rest)])))
|
||||
|
||||
|
|
@ -535,7 +544,7 @@ if (foo){
|
|||
[(_ x:honu-identifier ... semicolon . rest)
|
||||
(values
|
||||
(lambda ()
|
||||
(printf "Providing ~a\n" #'(x ...))
|
||||
(debug "Providing ~a\n" #'(x ...))
|
||||
#'(provide x.x ...))
|
||||
#'rest)])))
|
||||
|
||||
|
|
@ -590,19 +599,19 @@ if (foo){
|
|||
(emit-remark "Honu unparsed begin!" stx)
|
||||
#;
|
||||
(emit-remark "Honu unparsed begin" stx)
|
||||
(printf "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
|
||||
(debug "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
|
||||
(syntax-case stx ()
|
||||
[(_) #'(void)]
|
||||
[(_ . body)
|
||||
(begin
|
||||
(printf "Body is ~a\n" #'body)
|
||||
(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)])
|
||||
;; (printf "Rest is ~a\n" (syntax->datum rest))
|
||||
;; (debug "Rest is ~a\n" (syntax->datum rest))
|
||||
(with-syntax ([code code]
|
||||
[(rest ...) rest])
|
||||
(if (stx-null? #'(rest ...))
|
||||
|
|
@ -642,13 +651,13 @@ if (foo){
|
|||
|
||||
#;
|
||||
(define (honu-print arg)
|
||||
(printf "~a\n" arg))
|
||||
(debug "~a\n" arg))
|
||||
|
||||
(define-syntax (#%dynamic-honu-module-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ forms ...)
|
||||
(begin
|
||||
(printf "Module begin ~a\n" (syntax->datum #'(forms ...)))
|
||||
(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)))])
|
||||
|
|
|
|||
|
|
@ -175,8 +175,8 @@
|
|||
(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))
|
||||
;; (printf "head is ~a\n" (stx-car stx))
|
||||
;; (printf "= is ~a\n" =)
|
||||
;; (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 (... ...)))]
|
||||
|
|
@ -265,9 +265,9 @@
|
|||
(loop (cons #'(... ...) ellipses) body (cdr stx))]
|
||||
[(and (identifier? (car stx))
|
||||
(free-identifier=? (car stx) #'\;))
|
||||
;; (printf "Found a ; in ~a\n" (syntax->datum stx))
|
||||
;; (debug "Found a ; in ~a\n" (syntax->datum stx))
|
||||
(with-syntax ([all (cdr stx)])
|
||||
;; (printf "Found a ; -- ~a\n" (syntax->datum #'all))
|
||||
;; (debug "Found a ; -- ~a\n" (syntax->datum #'all))
|
||||
(syntax-parse #'all
|
||||
[((~and x (~not _:stop-class)) ... stop:stop-class y ...)
|
||||
(with-syntax ([(ellipses ...) ellipses]
|
||||
|
|
@ -313,8 +313,8 @@
|
|||
stx
|
||||
(let ([stx (reverse (syntax->list stx))])
|
||||
;; (debug-parse stx (ellipses1:ellipses-class ellipses:ellipses-class ... x ...))
|
||||
;; (printf "stx is ~a\n" stx)
|
||||
;; (printf "... = ~a\n" (free-identifier=? #'(... ...) (stx-car stx)))
|
||||
;; (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 ...)))])
|
||||
|
|
@ -352,7 +352,7 @@
|
|||
(pattern x:id #:when (free-identifier=? #'x #'(... ...))))
|
||||
(define-syntax-class delimiter-class
|
||||
(pattern x:id #:when (delimiter? #'x)))
|
||||
;; (printf "unpull ~a\n" (syntax->datum stx))
|
||||
;; (debug "unpull ~a\n" (syntax->datum stx))
|
||||
(syntax-parse stx
|
||||
#:literals (wrapped unwrap)
|
||||
[((~and z (~not (unwrap _ ...))) ... (unwrap (wrapped x ... delimiter:delimiter-class) ...) rest ...)
|
||||
|
|
@ -409,7 +409,7 @@
|
|||
(with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
|
||||
#'(x* ... ellipses1 ellipses ...))]
|
||||
[(x ...) (with-syntax ([(x* ...) (map do-it (syntax->list #'(x ...)))])
|
||||
(printf "x* is ~a\n" #'(x* ...))
|
||||
(debug "x* is ~a\n" #'(x* ...))
|
||||
#'(x* ...))]
|
||||
[else stx]))
|
||||
(syntax-case stx ()
|
||||
|
|
@ -440,7 +440,7 @@
|
|||
#;
|
||||
(define-syntax (honu-unparsed-expr stx)
|
||||
(define (fix stx)
|
||||
(printf "Fix ~a\n" (syntax->datum 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 ...))])
|
||||
|
|
@ -451,7 +451,7 @@
|
|||
#'(z* x* ...))]
|
||||
[else stx]
|
||||
))
|
||||
(printf "unparsed expr ~a\n" stx)
|
||||
(debug "unparsed expr ~a\n" stx)
|
||||
(fix (stx-cdr stx)))
|
||||
|
||||
(define-syntax (test2 stx)
|
||||
|
|
@ -495,7 +495,7 @@
|
|||
|
||||
(define foobar 0)
|
||||
|
||||
(define-honu-syntax honu-macro
|
||||
(define-honu-syntax honu-infix-macro
|
||||
(lambda (stx ctx)
|
||||
(define-splicing-syntax-class patterns
|
||||
#:literal-sets ([cruft #:phase (syntax-local-phase-level)])
|
||||
|
|
@ -505,14 +505,14 @@
|
|||
#:with (code ...) '()
|
||||
#:with (fixed ...) '()
|
||||
#:when (begin
|
||||
(printf "Trying to parse ~a\n" (syntax->datum #'(x ...)))
|
||||
(debug "Trying to parse ~a\n" (syntax->datum #'(x ...)))
|
||||
#f)]
|
||||
#;
|
||||
[pattern (~seq (#%braces template ...)
|
||||
(#%braces code ...))
|
||||
#:with (fixed ...) '()
|
||||
#:when (begin
|
||||
(printf "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...)))
|
||||
(debug "Got template as ~a. Code is ~a\n" (syntax->datum #'(template ...)) (syntax->datum #'(code ...)))
|
||||
#f)]
|
||||
[pattern (~seq (#%braces template ...)
|
||||
(#%braces code ...))
|
||||
|
|
@ -538,7 +538,165 @@
|
|||
[your-braces (datum->syntax #'name '#%braces #'name)]
|
||||
#;
|
||||
[your-parens (datum->syntax #'name '#%parens #'name)])
|
||||
;;(printf "Ok macro3 go!\n")
|
||||
(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 ...)
|
||||
[(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 ()
|
||||
(emit-remark "Excuting macro " (symbol->string 'name))
|
||||
result)))
|
||||
#'(rrest (... ...)))]
|
||||
...
|
||||
[else (raise-syntax-error 'name "bad syntax")]
|
||||
))))))
|
||||
#'rest)])
|
||||
(debug "Executing honu infix macro\n")
|
||||
(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)]
|
||||
)))
|
||||
|
||||
(define-honu-syntax honu-macro
|
||||
(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 ...))])
|
||||
(define-syntax-class honu-macro3
|
||||
;; #:literals (#%parens #%braces)
|
||||
#:literal-sets ([cruft ;;#:at stx
|
||||
#:phase (syntax-local-phase-level)
|
||||
])
|
||||
[pattern (_ name (#%parens literals ...)
|
||||
pattern:patterns ...
|
||||
. 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)
|
||||
|
|
@ -553,14 +711,14 @@
|
|||
(lambda () result))
|
||||
#'(rrest (... ...)))])))
|
||||
#;
|
||||
(printf "Original pattern ~a\n" (syntax->datum #'(pattern.fixed ... rrest (... ...))))
|
||||
(debug "Original pattern ~a\n" (syntax->datum #'(pattern.fixed ... rrest (... ...))))
|
||||
(apply-scheme-syntax
|
||||
(syntax/loc stx
|
||||
(define-honu-syntax name
|
||||
(lambda (stx ctx)
|
||||
#;
|
||||
(printf "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx))
|
||||
(printf "~a pattern is ~a\n" 'name '(pattern.fixed ... ...))
|
||||
(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 ...)
|
||||
|
|
@ -574,7 +732,7 @@
|
|||
(begin
|
||||
(emit-remark "Do macro transformer" (quote-syntax (pattern.code ...)))
|
||||
#;
|
||||
(printf "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...))))
|
||||
(debug "Macro transformer `~a'\n" (syntax->datum (quote-syntax (code ...))))
|
||||
(let ([result (let ()
|
||||
(honu-unparsed-begin pattern.code ...))])
|
||||
(lambda ()
|
||||
|
|
@ -606,7 +764,7 @@
|
|||
(values
|
||||
(honu-unparsed-begin code ...)
|
||||
(begin
|
||||
(printf "inside ~a stx is ~a\n" 'name stx)
|
||||
(debug "inside ~a stx is ~a\n" 'name stx)
|
||||
(syntax-parse stx #:literals (semicolon)
|
||||
[(_ semicolon rrest (... ...))
|
||||
#'(rrest (... ...))]))))))
|
||||
|
|
@ -687,7 +845,7 @@
|
|||
#;
|
||||
#'rrest))]))))
|
||||
#'rest))])
|
||||
(printf "Executing honu macro\n")
|
||||
(debug "Executing honu macro\n")
|
||||
(syntax-parse stx
|
||||
[out:honu-macro1 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
|
||||
[out:honu-macro3 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]
|
||||
|
|
@ -763,12 +921,12 @@
|
|||
(#%braces (#%braces name pattern ...))
|
||||
. rest)
|
||||
(begin
|
||||
(printf "Got literals ~a\n" #'(x ...))
|
||||
(printf "M is ~a, = to #%parens is ~a\n" #'m (free-identifier=? #'#%parens #'m))
|
||||
(printf "Z is ~a, = to #%braces is ~a\n" #'z (free-identifier=? #'#%braces #'z))
|
||||
(printf "Rest is ~a\n" (syntax->datum #'rest))
|
||||
(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))
|
||||
#;
|
||||
(printf "Got name ~a pattern ~a\n" #'name #'(pattern ...))
|
||||
(debug "Got name ~a pattern ~a\n" #'name #'(pattern ...))
|
||||
(raise-syntax-error 'honu-macro "f1" stx))]
|
||||
[else (raise-syntax-error 'honu-macro "fail" stx)]
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -1,21 +1,22 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "honu-typed-scheme.ss"
|
||||
"literals.ss"
|
||||
(require "honu-typed-scheme.rkt"
|
||||
"literals.rkt"
|
||||
syntax/parse
|
||||
mzlib/trace
|
||||
"syntax.ss"
|
||||
"syntax.rkt"
|
||||
(for-syntax syntax/parse
|
||||
syntax/stx
|
||||
racket/list
|
||||
racket/base
|
||||
"contexts.ss"
|
||||
"syntax.ss"
|
||||
"debug.rkt"
|
||||
"contexts.rkt"
|
||||
"syntax.rkt"
|
||||
(only-in racket (... scheme-ellipses))
|
||||
"literals.ss")
|
||||
(for-template "honu-typed-scheme.ss"
|
||||
"literals.ss"
|
||||
"syntax.ss"
|
||||
"literals.rkt")
|
||||
(for-template "honu-typed-scheme.rkt"
|
||||
"literals.rkt"
|
||||
"syntax.rkt"
|
||||
(only-in racket ...)
|
||||
))
|
||||
|
||||
|
|
@ -28,11 +29,11 @@
|
|||
(datum->syntax lexical consed lexical))
|
||||
|
||||
(define (replace-commas stuff)
|
||||
;; (printf "Replace commas with: ~a\n" (syntax->datum stuff))
|
||||
;; (debug "Replace commas with: ~a\n" (syntax->datum stuff))
|
||||
(syntax-parse stuff #:literals (ellipses-comma ellipses-comma*)
|
||||
[((ellipses-comma* z ...) thing blah ...)
|
||||
#;
|
||||
(printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(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 ...)
|
||||
|
|
@ -45,7 +46,7 @@
|
|||
#'(z honu-comma rest ...))]
|
||||
[((ellipses-comma z) thing blah ...)
|
||||
#;
|
||||
(printf "Thing ~a and blah ~a replaced ~a\n" #'thing #'(blah ...) (replace-commas #'(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 ...))
|
||||
|
|
@ -109,7 +110,7 @@
|
|||
|
||||
(define-syntax (fix-template stuff)
|
||||
(define (fix stuff)
|
||||
(printf "Macro fix template for ~a\n" (syntax->datum stuff))
|
||||
(debug "Macro fix template for ~a\n" (syntax->datum stuff))
|
||||
(syntax-parse stuff #:literals (ellipses-comma)
|
||||
[(any ellipses-comma rest ...)
|
||||
(define (addit item)
|
||||
|
|
@ -168,14 +169,14 @@
|
|||
|
||||
(define (replace stuff)
|
||||
#|
|
||||
(printf "Replacing ~a\n" (syntax->datum stuff))
|
||||
(printf "Local phase level ~a\n" (syntax-local-phase-level))
|
||||
(printf "Checking..\n")
|
||||
(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 ...)
|
||||
(printf "a: ~a\n" #'a)
|
||||
(printf "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))
|
||||
(printf "c: ~a = ... is ~a\n" #'c (and (identifier? #'c) (free-identifier=? #'c #'(... ...))))]
|
||||
(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
|
||||
|
|
@ -202,14 +203,14 @@
|
|||
[else stuff]
|
||||
))
|
||||
|
||||
(printf "Do fix template for ~a\n" (syntax->datum stuff))
|
||||
(debug "Do fix template for ~a\n" (syntax->datum stuff))
|
||||
(syntax-parse stuff
|
||||
[(_ blah)
|
||||
(let ([replaced (replace #'blah)])
|
||||
(printf "Replaced ~a\n" (syntax->datum replaced))
|
||||
(debug "Replaced ~a\n" (syntax->datum replaced))
|
||||
(with-syntax ([out2 replaced])
|
||||
(let ([x #'(apply-scheme-syntax (replace-commas #'out2))])
|
||||
(printf "Final syntax ~a\n" (syntax->datum x))
|
||||
(debug "Final syntax ~a\n" (syntax->datum x))
|
||||
x)))]
|
||||
#;
|
||||
[(_ blah ...) (fix #'(blah ...))]))
|
||||
|
|
@ -223,14 +224,14 @@
|
|||
(lambda ()
|
||||
(define (show-pattern-variables what)
|
||||
(cond
|
||||
[(syntax-pattern-variable? what) (printf "~a is a pattern variable\n") what]
|
||||
[(syntax-pattern-variable? what) (debug "~a is a pattern variable\n") what]
|
||||
[(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
|
||||
[else (printf "~a is *not* a pattern variable\n" what)]))
|
||||
[else (debug "~a is *not* a pattern variable\n" what)]))
|
||||
|
||||
#;
|
||||
(printf "Original code is ~a\n" (syntax->datum #'(expr ...)))
|
||||
(debug "Original code is ~a\n" (syntax->datum #'(expr ...)))
|
||||
#;
|
||||
(printf "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(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
|
||||
|
|
@ -245,7 +246,7 @@
|
|||
(with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
|
||||
#'a)
|
||||
|
||||
(printf "Making unparsed syntax with `~a'\n" (syntax->datum #'(expr (... ...))))
|
||||
(debug "Making unparsed syntax with `~a'\n" (syntax->datum #'(expr (... ...))))
|
||||
|
||||
#;
|
||||
(with-syntax ([unparsed (make-unparsed #'(expr ...))])
|
||||
|
|
@ -274,7 +275,7 @@
|
|||
|
||||
#;
|
||||
(let ([x #'(fix-template (honu-unparsed-begin expr ...))])
|
||||
(printf "Final syntax ~a\n" (syntax->datum x))
|
||||
(debug "Final syntax ~a\n" (syntax->datum x))
|
||||
x)
|
||||
|
||||
#;
|
||||
|
|
@ -299,12 +300,12 @@
|
|||
(lambda ()
|
||||
(define (show-pattern-variables what)
|
||||
(cond
|
||||
[(syntax-pattern-variable? what) (printf "~a is a pattern variable\n") what]
|
||||
[(syntax-pattern-variable? what) (debug "~a is a pattern variable\n") what]
|
||||
[(stx-pair? what) (for-each show-pattern-variables (syntax->list what))]
|
||||
[else (printf "~a is *not* a pattern variable\n" what)]))
|
||||
[else (debug "~a is *not* a pattern variable\n" what)]))
|
||||
|
||||
(define (make-unparsed code)
|
||||
(printf "Make unparsed in ~a. expression-context? ~a\n" ctx (expression-context? ctx))
|
||||
(debug "Make unparsed in ~a. expression-context? ~a\n" ctx (expression-context? ctx))
|
||||
(with-syntax ([(code ...) code])
|
||||
(cond
|
||||
[(expression-context? ctx)
|
||||
|
|
@ -312,9 +313,9 @@
|
|||
[else #'(honu-unparsed-begin code ...)])))
|
||||
|
||||
#;
|
||||
(printf "Original code is ~a\n" (syntax->datum #'(expr ...)))
|
||||
(debug "Original code is ~a\n" (syntax->datum #'(expr ...)))
|
||||
#;
|
||||
(printf "Expanded is ~a\n" (syntax->datum (expand-syntax-once #'(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
|
||||
|
|
@ -329,7 +330,7 @@
|
|||
(with-syntax ([a #'(fix-template #'(honu-unparsed-begin expr ...))])
|
||||
#'a)
|
||||
|
||||
(printf "Making unparsed syntax???\n")
|
||||
(debug "Making unparsed syntax???\n")
|
||||
(with-syntax ([unparsed (make-unparsed #'(expr ...))])
|
||||
#'(fix-template unparsed))
|
||||
|
||||
|
|
@ -343,7 +344,7 @@
|
|||
|
||||
#;
|
||||
(let ([x #'(fix-template (honu-unparsed-begin expr ...))])
|
||||
(printf "Final syntax ~a\n" (syntax->datum x))
|
||||
(debug "Final syntax ~a\n" (syntax->datum x))
|
||||
x)
|
||||
|
||||
#;
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
syntax/parse
|
||||
syntax/parse/experimental/splicing
|
||||
"syntax.ss"
|
||||
"debug.rkt"
|
||||
(for-syntax syntax/parse
|
||||
racket/base)
|
||||
macro-debugger/emit
|
||||
|
|
@ -30,7 +31,7 @@
|
|||
(begin-for-syntax
|
||||
(current-failure-handler
|
||||
(lambda (_ f)
|
||||
(printf "Failure is ~a\n" (failure->sexpr (simplify-failure f)))
|
||||
(debug "Failure is ~a\n" (failure->sexpr (simplify-failure f)))
|
||||
(error 'failed "whatever"))))
|
||||
|
||||
(define-syntax-class block
|
||||
|
|
@ -52,24 +53,41 @@
|
|||
(length (syntax->list mstart))
|
||||
(let loop ([start mstart]
|
||||
[count 0])
|
||||
;; (printf "Checking ~a vs ~a\n" start end)
|
||||
;; (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))]))))
|
||||
|
||||
(define-primitive-splicing-syntax-class (infix-macro-class left-expression context)
|
||||
#:attrs (result)
|
||||
#:description "infix-macro"
|
||||
(lambda (stx fail)
|
||||
(cond
|
||||
[(stx-null? stx) (fail)]
|
||||
[(get-infix-transformer stx) => (lambda (transformer)
|
||||
(define full-stx (datum->syntax left-expression (cons left-expression stx)))
|
||||
(define introducer (make-syntax-introducer))
|
||||
(debug "Transforming honu infix macro ~a\n" (stx-car stx))
|
||||
(let-values ([(used rest)
|
||||
(transformer (introducer full-stx) context)])
|
||||
(debug "Result is ~a. Object position is ~a out of expression ~a\n" used (syntax-object-position full-stx (introducer rest)) (syntax->datum full-stx))
|
||||
(list (introducer rest) (syntax-object-position full-stx (introducer rest))
|
||||
(introducer (used)))))]
|
||||
[else (fail)])))
|
||||
|
||||
(define-primitive-splicing-syntax-class (honu-transformer context)
|
||||
#:attrs (result)
|
||||
#:description "honu-expr"
|
||||
(lambda (stx fail)
|
||||
(printf "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx))
|
||||
(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)
|
||||
(printf "Parsed honu-syntax rest ~a position ~a out ~a\n"
|
||||
(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)
|
||||
|
|
@ -77,15 +95,15 @@
|
|||
[else #f]
|
||||
#;
|
||||
[else #f => (lambda (exprs)
|
||||
(printf "Ignoring honu-syntax 1!\n")
|
||||
(debug "Ignoring honu-syntax 1!\n")
|
||||
(list 0 #''()))]
|
||||
)]
|
||||
[(get-transformer stx) => (lambda (transformer)
|
||||
(define introducer (make-syntax-introducer))
|
||||
(printf "Transforming honu macro ~a\n" (stx-car stx))
|
||||
(debug "Transforming honu macro ~a\n" (stx-car stx))
|
||||
(let-values ([(used rest)
|
||||
(transformer (introducer stx) context)])
|
||||
(printf "Result is ~a. Object position is ~a out of expression ~a\n" used (syntax-object-position stx (introducer rest)) (syntax->datum stx))
|
||||
(debug "Result is ~a. Object position is ~a out of expression ~a\n" used (syntax-object-position stx (introducer rest)) (syntax->datum stx))
|
||||
(list (introducer rest) (syntax-object-position stx (introducer rest))
|
||||
(introducer (used)))))]
|
||||
|
||||
|
|
@ -95,7 +113,7 @@
|
|||
#:attributes (result)
|
||||
#:description "honu-expr"
|
||||
(lambda (stx fail)
|
||||
(printf "Honu expr ~a\n" stx)
|
||||
(debug "Honu expr ~a\n" stx)
|
||||
(cond
|
||||
[(stx-null? stx) (fail)]
|
||||
#;
|
||||
|
|
@ -106,18 +124,18 @@
|
|||
[else #f]
|
||||
#;
|
||||
[else #f => (lambda (exprs)
|
||||
(printf "Ignoring honu-syntax 1!\n")
|
||||
(debug "Ignoring honu-syntax 1!\n")
|
||||
(list 0 #''()))]
|
||||
)]
|
||||
#;
|
||||
[(syntax-parse stx #:literals (honu-syntax)
|
||||
[(honu-syntax expr ...) #'(expr ...)]
|
||||
[else #f]) => (lambda (exprs)
|
||||
(printf "Ignoring honu-syntax 2!\n")
|
||||
(debug "Ignoring honu-syntax 2!\n")
|
||||
(list '() 0 exprs))]
|
||||
[(get-transformer stx) => (lambda (transformer)
|
||||
(define introducer (make-syntax-introducer))
|
||||
(printf "Transforming honu macro ~a\n" (car stx))
|
||||
(debug "Transforming honu macro ~a\n" (car stx))
|
||||
(let-values ([(used rest)
|
||||
(transformer (introducer stx) context)])
|
||||
(list (introducer rest) (syntax-object-position stx rest)
|
||||
|
|
@ -140,12 +158,12 @@
|
|||
(#%parens (~var arg (expression-1 context)) ...))
|
||||
#:with call
|
||||
(begin
|
||||
(printf "Resulting call. e is ~a -- ~a\n" #'e (syntax->datum #'(e arg.result ...)))
|
||||
(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
|
||||
(printf "Trying a call on ~a and ~a\n" #'e #'(rest ...))
|
||||
(debug "Trying a call on ~a and ~a\n" #'e #'(rest ...))
|
||||
#f)]
|
||||
|
||||
[pattern (~seq (~var e (expression-simple context))
|
||||
|
|
@ -158,7 +176,7 @@
|
|||
...))
|
||||
#:with call
|
||||
(begin
|
||||
(printf "Resulting call is ~a\n" (syntax->datum #'(e.result arg.result ...)))
|
||||
(debug "Resulting call is ~a\n" (syntax->datum #'(e.result arg.result ...)))
|
||||
#'(e.result arg.result ...))]
|
||||
|
||||
#;
|
||||
|
|
@ -175,7 +193,7 @@
|
|||
...))
|
||||
#:with call
|
||||
(begin
|
||||
(printf "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...)))
|
||||
(debug "Resulting call is ~a\n" (syntax->datum #'(e.x arg.result ...)))
|
||||
#'(e.x arg.result ...))])
|
||||
|
||||
(define-splicing-syntax-class honu-identifier
|
||||
|
|
@ -191,7 +209,7 @@
|
|||
the-expression-context
|
||||
#;
|
||||
context))) #:with result #'e.result]
|
||||
[pattern (~seq x:number) #:with result (begin (printf "got a number ~a\n" #'x) #'x)]
|
||||
[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])
|
||||
|
||||
|
|
@ -201,11 +219,11 @@
|
|||
#;
|
||||
[pattern (~seq a 1 2 3 b 4 5 6)]
|
||||
|
||||
[pattern (~seq x) #:with result #f #:when (begin (printf "Expression last ~a. Raw? ~a\n" #'x (raw-scheme? #'x)) #f)]
|
||||
[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 (printf "raw syntax ~a\n" #'raw)
|
||||
(begin (debug "raw syntax ~a\n" #'raw)
|
||||
(if (stx-pair? #'raw)
|
||||
(stx-car #'raw)
|
||||
#'raw))]
|
||||
|
|
@ -221,7 +239,7 @@
|
|||
context)))
|
||||
#:with result #'e.result
|
||||
#:with rest #'e.rest]
|
||||
[pattern (~seq x:number) #:with result (begin (printf "got a number ~a\n" #'x) #'x)]
|
||||
[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]
|
||||
|
|
@ -242,12 +260,12 @@
|
|||
(~var new-right (do-rest context ((attribute op.func) left (attribute right.result)))))
|
||||
#:with result
|
||||
(begin
|
||||
(printf "Left was ~a\n" left)
|
||||
(debug "Left was ~a\n" left)
|
||||
#;
|
||||
(attribute new-right.result)
|
||||
(apply-scheme-syntax (attribute new-right.result))))
|
||||
|
||||
(pattern (~seq) #:with result (begin #;(printf "Left is still ~a\n" left)
|
||||
(pattern (~seq) #:with result (begin #;(debug "Left is still ~a\n" left)
|
||||
left)))
|
||||
|
||||
(define-splicing-syntax-class (name context)
|
||||
|
|
@ -286,7 +304,7 @@
|
|||
(define (create-stuff names operator-stuff)
|
||||
(define make (syntax-lambda (expression next-expression (ops ...))
|
||||
#;
|
||||
(printf "Make infix ~a ~a\n" (syntax->datum #'expression) (syntax->datum #'next-expression))
|
||||
(debug "Make infix ~a ~a\n" (syntax->datum #'expression) (syntax->datum #'next-expression))
|
||||
#'(define-infix-operator expression next-expression ops ...)))
|
||||
(for/list ([name1 (drop-last names)]
|
||||
[name2 (cdr names)]
|
||||
|
|
@ -343,9 +361,18 @@
|
|||
([honu-. (sl (left right) #'(get-field right left))])
|
||||
))
|
||||
|
||||
(define-splicing-syntax-class (infix-macro context)
|
||||
[pattern (~seq (~var e (expression-1 context))
|
||||
(~var infix (infix-macro-class #'e.result context)))
|
||||
#:with result #'infix.result]
|
||||
[pattern (~seq (~var e (expression-1 context))) #:with result #'e.result])
|
||||
|
||||
(define-splicing-syntax-class (ternary context)
|
||||
#:literals (honu-? honu-:)
|
||||
[pattern (~seq (~var condition (expression-1 context))
|
||||
[pattern (~seq (~var condition
|
||||
(infix-macro context)
|
||||
#;
|
||||
(expression-1 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))))
|
||||
|
|
@ -358,7 +385,7 @@
|
|||
|
||||
(define-splicing-syntax-class (debug-here d)
|
||||
[pattern (~seq) #:when (begin
|
||||
(printf "Debug parse I got here ~a\n" d)
|
||||
(debug "Debug parse I got here ~a\n" d)
|
||||
#t)])
|
||||
|
||||
(define (make-assignment left right)
|
||||
|
|
@ -394,7 +421,7 @@
|
|||
#;
|
||||
(let-values ([(parsed dont-care)
|
||||
(parse-block-one/2 #'(stuff ...) context)])
|
||||
(printf "Parsed ~a. Dont care rest ~a\n" parsed dont-care)
|
||||
(debug "Parsed ~a. Dont care rest ~a\n" parsed dont-care)
|
||||
parsed)]
|
||||
[pattern ((~var x0 (debug-here (format "expression top\n")))
|
||||
(~var e (ternary context))
|
||||
|
|
@ -424,7 +451,22 @@
|
|||
proc))
|
||||
(make-honu-trans proc))
|
||||
|
||||
(define-values (prop:honu-infix-transformer honu-infix-transformer? honu-infix-transformer-ref)
|
||||
(make-struct-type-property 'honu-infix-transformer))
|
||||
|
||||
(define-values (struct:honu-infix-trans make-honu-infix-trans honu-infix-trans? honu-infix-trans-ref honu-infix-trans-set!)
|
||||
(make-struct-type 'honu-infix-trans #f 1 0 #f
|
||||
(list (list prop:honu-infix-transformer #t))
|
||||
(current-inspector) 0))
|
||||
|
||||
(define (make-honu-infix-transformer proc)
|
||||
(unless (and (procedure? proc)
|
||||
(procedure-arity-includes? proc 2))
|
||||
(raise-type-error
|
||||
'define-honu-syntax
|
||||
"procedure (arity 2)"
|
||||
proc))
|
||||
(make-honu-infix-trans proc))
|
||||
|
||||
#;
|
||||
(define-honu-syntax honu-scheme
|
||||
|
|
@ -435,11 +477,11 @@
|
|||
(define (fix-output stx)
|
||||
#f
|
||||
#|
|
||||
(printf "Fix output ~a\n" (syntax->datum stx))
|
||||
(debug "Fix output ~a\n" (syntax->datum stx))
|
||||
(when (and (stx-pair? stx) (equal? 'honu-syntax (syntax->datum (stx-car stx))))
|
||||
(printf "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax)))
|
||||
(debug "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax)))
|
||||
(when (identifier? stx)
|
||||
(printf "Current phase ~a stx at ~a honu-scheme ~a same? ~a\n" (syntax-local-phase-level) (identifier-binding 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)
|
||||
))
|
||||
|
|
@ -449,7 +491,7 @@
|
|||
#;
|
||||
[((honu-syntax (#%parens x ...) y ...) rest ...)
|
||||
#;
|
||||
(printf "a1\n")
|
||||
(debug "a1\n")
|
||||
(with-syntax ([(y* ...) (fix-output #'(y ... rest ...))])
|
||||
(syntax/loc stx
|
||||
((honu-syntax x ...) y* ...)))]
|
||||
|
|
@ -461,20 +503,20 @@
|
|||
#;
|
||||
[(honu-syntax (#%parens x ...) y ...)
|
||||
#;
|
||||
(printf "a2\n")
|
||||
(debug "a2\n")
|
||||
(with-syntax ([(y* ...) (fix-output #'(y ...))])
|
||||
(syntax/loc stx
|
||||
(x ... y* ...)))]
|
||||
;; dont touch real syntax
|
||||
[(syntax stuff ...)
|
||||
#;
|
||||
(printf " aa\n")
|
||||
(debug " aa\n")
|
||||
stx]
|
||||
#;
|
||||
[honu-scheme (raise-syntax-error 'asdfioj "got honu-scheme")]
|
||||
[(z x ...)
|
||||
#;
|
||||
(printf "a3\n")
|
||||
(debug "a3\n")
|
||||
(datum->syntax stx (cons (fix-output #'z)
|
||||
(fix-output #'(x ...)))
|
||||
stx)
|
||||
|
|
@ -489,7 +531,7 @@
|
|||
(raise-syntax-error 'fix-output "invalid use of honu-syntax")]
|
||||
[else
|
||||
#;
|
||||
(printf " no change\n")
|
||||
(debug " no change\n")
|
||||
stx]))
|
||||
|
||||
(define-splicing-syntax-class expression
|
||||
|
|
@ -498,7 +540,7 @@
|
|||
|
||||
(define-splicing-syntax-class (whats-here? hm)
|
||||
[pattern (~seq x ...)
|
||||
#:when (begin (printf "Whats at `~a': `~a'\n" hm (syntax->datum #'(x ...)))
|
||||
#:when (begin (debug "Whats at `~a': `~a'\n" hm (syntax->datum #'(x ...)))
|
||||
#f)])
|
||||
|
||||
#;
|
||||
|
|
@ -566,7 +608,7 @@
|
|||
[pattern ((~seq (~var expr (expression-1 the-expression-context)) (~optional honu-comma)) ...)])
|
||||
|
||||
(define (parse-an-expr stx)
|
||||
(printf "Parse an expr ~a\n" (syntax->datum stx))
|
||||
(debug "Parse an expr ~a\n" (syntax->datum stx))
|
||||
(syntax-parse (with-syntax ([(s ...) stx])
|
||||
#'(s ...))
|
||||
#;
|
||||
|
|
@ -583,12 +625,12 @@
|
|||
(define (parse-one stx context)
|
||||
#;
|
||||
(let-values ([(a b) (debug-parse #'(SQL_create_insert) ((~seq x:expression)))])
|
||||
(printf "debug parse for ~a is ~a and ~a\n" 'SQL_create_insert a b))
|
||||
(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)))))])
|
||||
(printf "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b))
|
||||
(debug "debug parse for ~a is ~a and ~a\n" (syntax->datum stx) a b))
|
||||
|
||||
;; (printf "~a\n" (syntax-class-parse function stx))
|
||||
;; (debug "~a\n" (syntax-class-parse function stx))
|
||||
(syntax-parse stx
|
||||
#;
|
||||
[(raw:raw-scheme-syntax . rest) (values #'raw #'rest)]
|
||||
|
|
@ -598,7 +640,7 @@
|
|||
#;
|
||||
[(x:number . rest) (values #'x #'rest)]
|
||||
))
|
||||
(printf "Parsing ~a\n" (syntax->datum stx))
|
||||
(debug "Parsing ~a\n" (syntax->datum stx))
|
||||
(cond
|
||||
[(stx-null? stx) (values stx '())]
|
||||
#;
|
||||
|
|
@ -607,7 +649,7 @@
|
|||
(list #'(expr ...)
|
||||
#'rest)
|
||||
#;
|
||||
(printf "Parsed honu-syntax rest ~a position ~a out ~a\n"
|
||||
(debug "Parsed honu-syntax rest ~a position ~a out ~a\n"
|
||||
#'rest (syntax-object-position stx #'rest)
|
||||
#'(honu-unparsed-begin expr ...))
|
||||
#;
|
||||
|
|
@ -616,7 +658,7 @@
|
|||
[else #f]
|
||||
#;
|
||||
[else #f => (lambda (exprs)
|
||||
(printf "Ignoring honu-syntax 1!\n")
|
||||
(debug "Ignoring honu-syntax 1!\n")
|
||||
(list 0 #''()))]
|
||||
) => (lambda (all)
|
||||
(let ([to-parse (car all)]
|
||||
|
|
@ -636,9 +678,9 @@
|
|||
(define introduce (compose introducer syntax-local-introduce))
|
||||
#;
|
||||
(define unintroduce (compose syntax-local-introduce introducer))
|
||||
(printf "Parse one: execute transformer ~a ~a\n" (stx-car stx) transformer)
|
||||
(debug "Parse one: execute transformer ~a ~a\n" (stx-car stx) transformer)
|
||||
#;
|
||||
(printf "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b)))
|
||||
(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)))
|
||||
|
|
@ -647,14 +689,14 @@
|
|||
(lambda (reparse rest)
|
||||
;; (define fixed (fix-output reparse))
|
||||
(define fixed reparse)
|
||||
(printf "Transformer gave us ~a\n" (syntax->datum reparse))
|
||||
(debug "Transformer gave us ~a\n" (syntax->datum reparse))
|
||||
#;
|
||||
(values reparse rest)
|
||||
#;
|
||||
(values (fix-output reparse) rest)
|
||||
#;
|
||||
(printf "Macroized ~a and ~a\n" reparse rest)
|
||||
(printf "Fixed syntax ~a\n" (syntax->datum fixed))
|
||||
(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)
|
||||
|
|
@ -677,6 +719,12 @@
|
|||
(and (positive? (string-length str))
|
||||
(memq (string-ref str 0) sym-chars)))))))
|
||||
|
||||
(define (get-infix-transformer stx)
|
||||
(let ([check (stx-car stx)])
|
||||
(and (identifier? check)
|
||||
(let ([value (syntax-local-value check (lambda () #f))])
|
||||
(and (honu-infix-transformer? value) value)))))
|
||||
|
||||
;; returns a transformer or #f
|
||||
(define (get-transformer stx)
|
||||
;; if its an identifier and bound to a transformer return it
|
||||
|
|
@ -684,7 +732,7 @@
|
|||
(and (stx-pair? stx)
|
||||
(identifier? (stx-car stx))
|
||||
(let ([v (begin
|
||||
(printf "Transformer is ~a. Local value is ~a\n" (stx-car stx) (syntax-local-value (stx-car stx) (lambda () #f)))
|
||||
(debug "Transformer is ~a. Local value is ~a\n" (stx-car stx) (syntax-local-value (stx-car stx) (lambda () #f)))
|
||||
(syntax-local-value (stx-car stx) (lambda () #f)))])
|
||||
(and (honu-transformer? v) v))))
|
||||
(define (special-transformer stx)
|
||||
|
|
@ -714,7 +762,7 @@
|
|||
(and (honu-transformer? v) v))]
|
||||
[else #f]))))
|
||||
#;
|
||||
(printf "~a bound transformer? ~a at phase level ~a identifiers: ~a\n" stx (bound-transformer stx) (syntax-local-phase-level)
|
||||
(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)])
|
||||
|
|
@ -732,7 +780,7 @@
|
|||
(syntax-case stx ()
|
||||
[(_ expr ...)
|
||||
(begin
|
||||
(printf "Honu syntax on ~a\n" #'(expr ...))
|
||||
(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))])))
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@
|
|||
#'(honu-unparsed-expr expr)
|
||||
#;
|
||||
(begin
|
||||
(printf "honu syntax ~a\n" stx)
|
||||
(debug "honu syntax ~a\n" stx)
|
||||
(raise-syntax-error 'honu-syntax "dont call this")
|
||||
#'(make-honu-transformer (lambda (stx ctx)
|
||||
(printf "honu syntax ~a\n" stx)
|
||||
(debug "honu syntax ~a\n" stx)
|
||||
#'(expr ...))))]))
|
||||
|
||||
#;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang scheme
|
||||
|
||||
(provide (except-out (all-defined-out) test))
|
||||
(require "debug.rkt")
|
||||
|
||||
#;
|
||||
(provide delim-identifier=?
|
||||
|
|
@ -64,10 +65,10 @@
|
|||
(map syntax->datum rest))
|
||||
(equal? (syntax->datum expected-delimiter)
|
||||
(syntax->datum hit))))
|
||||
(printf "failure: original ~a until ~a\n" (syntax->datum original) (map syntax->datum (list delimiter)))
|
||||
(printf " before expected ~a actual ~a\n" (syntax->datum expected-before) (map syntax->datum before))
|
||||
(printf " rest expected ~a actual ~a\n" (syntax->datum expected-rest) (map syntax->datum rest))
|
||||
(printf " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
|
||||
(debug "failure: original ~a until ~a\n" (syntax->datum original) (map syntax->datum (list delimiter)))
|
||||
(debug " before expected ~a actual ~a\n" (syntax->datum expected-before) (map syntax->datum before))
|
||||
(debug " rest expected ~a actual ~a\n" (syntax->datum expected-rest) (map syntax->datum rest))
|
||||
(debug " delimiter expected ~a actual ~a\n" (syntax->datum expected-delimiter) (syntax->datum hit))
|
||||
))))
|
||||
|
||||
(test)
|
||||
|
|
|
|||
4
collects/honu/private/keywords.honu
Normal file
4
collects/honu/private/keywords.honu
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang honu/core
|
||||
|
||||
provide then;
|
||||
keywords then;
|
||||
7
collects/honu/private/patterns.honu
Normal file
7
collects/honu/private/patterns.honu
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
#lang honu/core
|
||||
|
||||
require (forTemplate "keywords.honu");
|
||||
|
||||
provide condition_clause;
|
||||
|
||||
pattern condition_clause literals (then) (condition_result out_result) [condition:expression then out:expression_comma];
|
||||
Loading…
Reference in New Issue
Block a user