suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

start to get transformers to work. weave in scheme syntax

Browse Source
This commit is contained in:
Jon Rafkind 2010-05-11 10:38:29 -06:00
parent 3d52f5ff12
commit 066166ce65
3 changed files with 62 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/honu/main.rkt
View File

@ -7,8 +7,11 @@
;; "private/honu.ss"
"private/parse.ss"
(for-syntax "private/literals.ss")
(for-syntax "private/honu-typed-scheme.ss")
(for-syntax "private/parse.ss")
"private/literals.ss"
"private/syntax.ss"
(for-syntax "private/syntax.ss")
"private/macro.ss")
(define test-x-class
@ -33,8 +36,14 @@
)
#%datum
(for-syntax #%datum
display
with-syntax
(rename-out (semicolon \;
)))
)
(honu-syntax syntax)
(honu-scheme scheme2)
(scheme-syntax schemeSyntax)
))
#%braces
#%parens
x
@ -42,7 +51,6 @@
false
display
display2
(for-syntax display)
newline
else
foobar2000
@ -52,6 +60,8 @@
(honu-macro-item macroItem)
(honu-macro macro)
(honu-syntax syntax)
#;
(honu-scheme scheme2)
(scheme-syntax schemeSyntax)
))

6
collects/honu/private/honu-typed-scheme.rkt
View File

@ -320,7 +320,6 @@ 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-honu-syntax honu-provide
(lambda (stx ctx)
(syntax-parse stx
@ -340,6 +339,11 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(values #'(define-syntax-class name [pattern x])
#'rest)])))
(define-honu-syntax honu-scheme
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon)
[(_ template semicolon rest ...) (values #'template #'(rest ...))])))
(define-honu-syntax honu-if
(lambda (stx ctx)
(define (parse-complete-block stx)

63
collects/honu/private/parse.rkt
View File

@ -220,19 +220,56 @@
#:with result #'e.result])
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
(make-struct-type-property 'honu-transformer))
(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
(make-struct-type 'honu-trans #f 1 0 #f
(list (list prop:honu-transformer #t))
(current-inspector) 0))
(define (make-honu-transformer proc)
(unless (and (procedure? proc)
(procedure-arity-includes? proc 2))
(raise-type-error
'define-honu-syntax
"procedure (arity 2)"
proc))
(make-honu-trans proc))
#;
(define-honu-syntax honu-scheme
(lambda (stx ctx)
(syntax-parse stx
[(_ template rest ...) (values #'template #'(rest ...))])))
(define (fix-output stx)
#|
(printf "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)))
(when (identifier? stx)
(printf "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 scheme-syntax syntax)
(syntax-parse stx #:literals (honu-syntax #%parens syntax)
[((honu-syntax (#%parens x ...) y ...) rest ...)
#;
(printf "a1\n")
(with-syntax ([(y* ...) (fix-output #'(y ... rest ...))])
(syntax/loc stx
(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 ...)
#;
(printf "a2\n")
@ -244,6 +281,8 @@
#;
(printf " aa\n")
stx]
#;
[honu-scheme (raise-syntax-error 'asdfioj "got honu-scheme")]
[(z x ...)
#;
(printf "a3\n")
@ -278,7 +317,7 @@
(call-values (transformer stx context)
(lambda (reparse rest)
(define fixed (fix-output reparse))
(printf "Transformer gave us ~a\n" reparse)
(printf "Transformer gave us ~a\n" (syntax->datum reparse))
#;
(values reparse rest)
#;
@ -296,8 +335,7 @@
))]
[else (parse-one stx context)]))
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
(make-struct-type-property 'honu-transformer))
(define operator?
(let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")])
@ -307,19 +345,6 @@
(and (positive? (string-length str))
(memq (string-ref str 0) sym-chars)))))))
(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!)
(make-struct-type 'honu-trans #f 1 0 #f
(list (list prop:honu-transformer #t))
(current-inspector) 0))
(define (make-honu-transformer proc)
(unless (and (procedure? proc)
(procedure-arity-includes? proc 2))
(raise-type-error
'define-honu-syntax
"procedure (arity 2)"
proc))
(make-honu-trans proc))
@ -330,7 +355,9 @@
(define (bound-transformer stx)
(and (stx-pair? stx)
(identifier? (stx-car stx))
(let ([v (syntax-local-value (stx-car stx) (lambda () #f))])
(let ([v (begin
(printf "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 () (stx-car stx))))])
(and (honu-transformer? v) v))))
(define (special-transformer stx)
(and (stx-pair? stx)