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

implement honu-syntax

Browse Source
This commit is contained in:
jon 2010-05-05 15:56:51 -06:00 committed by Jon Rafkind
parent 99e6eb5e9d
commit 2f5593a104
6 changed files with 164 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/honu/main.rkt
View File

@ -6,6 +6,7 @@
;; "private/honu.ss"
"private/parse.ss"
"private/literals.ss"
"private/syntax.ss"
"private/macro.ss")
(define test-x-class
@ -30,6 +31,7 @@
)
#%datum
#%braces
#%parens
x
true
false
@ -37,11 +39,13 @@
display2
newline
else
foobar2000
(rename-out
(honu-if if)
(honu-provide provide)
(honu-macro-item macroItem)
(honu-macro macro)
(honu-syntax syntax)
))
#;

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

@ -269,8 +269,9 @@
(lambda (transformer)
(let-values ([(code rest) (transformer body context)])
(combine-k code rest)))]
[else (call-values parse-one (extract-until body (list #'\;
)))]))
[else (call-values (extract-until body (list #'\;
))
parse-one )]))
#|
(define-honu-macro (e ... * e ... \;))
@ -295,13 +296,6 @@ x(2)
)
(define-syntax (define-honu-syntax stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
(with-syntax ([id id]
[rhs rhs])
#'(define-syntax id (make-honu-transformer rhs)))))
#|
Yes, check out head patterns and splicing syntax classes.
@ -320,6 +314,14 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
|#
(define-syntax (define-honu-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-transformer rhs))))))
(define-honu-syntax honu-provide
(lambda (stx ctx)
(syntax-parse stx
@ -328,6 +330,8 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(values #'(provide something)
#'rest)])))
;; (honu-syntax ...)
(define-honu-syntax honu-macro-item
(lambda (stx ctx)
(syntax-parse stx
@ -465,11 +469,18 @@ if (foo){
(define-syntax (honu-top stx)
(raise-syntax-error #f "interactive use is not yet supported"))
(define-syntax (foobar2000 stx)
(printf "Called foobar2000 on ~a\n" (syntax->datum stx))
(syntax-case stx ()
[(_ x y ...) #'(printf "foobar2000 ~a\n" x)]))
(define (display2 x y)
(printf "~a ~a" x y))
(define-syntax (honu-unparsed-begin stx)
;; (printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(syntax-case stx ()
[(_) #'(begin (void))]
[(_ . body) (let-values ([(code rest) (parse-block-one/2 #'body
@ -479,7 +490,8 @@ if (foo){
;; (printf "Rest is ~a\n" (syntax->datum rest))
(with-syntax ([code code]
[(rest ...) rest])
#'(begin code (honu-unparsed-begin rest ...))))]
(syntax/loc stx
(begin code (honu-unparsed-begin rest ...)))))]
#;
[(_ . body) (let-values ([(code rest) (parse-block-one the-top-block-context
#'body
@ -490,9 +502,17 @@ if (foo){
[(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-syntax (#%dynamic-honu-module-begin stx)
(syntax-case stx ()
[(_ forms ...)
(begin
(printf "Module begin ~a\n" (syntax->datum #'(forms ...)))
#'(#%plain-module-begin (honu-unparsed-begin forms ...)))]))

2
collects/honu/private/literals.rkt
View File

@ -16,4 +16,4 @@
honu-= honu-+= honu--= honu-*= honu-/= honu-%=
honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
honu-? honu-: honu-comma honu-. #%braces)
honu-? honu-: honu-comma honu-. #%braces #%parens)

67
collects/honu/private/macro.rkt
View File

@ -1,6 +1,9 @@
#lang scheme/base
(require "honu-typed-scheme.ss"
"literals.ss"
"parse.ss"
"syntax.ss"
(for-syntax "debug.ss"
"contexts.ss"
scheme/base
@ -11,6 +14,17 @@
(provide honu-macro)
(define-syntax (ensure-defined stx)
(syntax-case stx ()
[(_ id ...)
(begin
(for-each (lambda (id)
(syntax-local-value id (lambda () (raise-syntax-error 'syntax-id "not defined" id))))
(syntax->list #'(id ...)))
#'(void))]))
(ensure-defined #%parens #%braces)
(define-for-syntax (extract-conventions pattern)
(let loop ([out '()]
[in pattern])
@ -26,9 +40,6 @@
(loop out #'(rest1 rest ...))]
[(foo) out])))
(define-syntax (semicolon stx)
stx)
(define-for-syntax (extract-patterns pattern)
(let loop ([out '()]
[in pattern])
@ -311,7 +322,8 @@
(syntax-case stx ()
[(_ x ...) (do-it #'(x ...))]))
;; (provide unpull)
(provide (for-syntax unpull))
#;
(define-honu-syntax unpull
(lambda (stx ctx)
@ -355,6 +367,23 @@
'pattern))]
)))]))
#;
(define-syntax (honu-unparsed-expr stx)
(define (fix stx)
(printf "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]
))
(printf "unparsed expr ~a\n" stx)
(fix (stx-cdr stx)))
(define-syntax (test2 stx)
(syntax-case stx ()
[(_ x ...)
@ -383,7 +412,8 @@
(syntax->list #'(pattern ...)))]
)
(values
#'(define-honu-syntax name
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
;; (define-literal-set literals (honu-literal ...))
(syntax-parse stx
@ -397,16 +427,18 @@
(cond
[(type-context? ctx) (X)]
[(type-or-expression-context? ctx) (X)]
[(expression-context? ctx) #'(honu-unparsed-expr out (... ...))]
[(expression-context? ctx) (syntax/loc stx (honu-unparsed-expr (out (... ...))))]
[(expression-block-context? ctx)
#'(honu-unparsed-begin out (... ...))]
(syntax/loc stx
(honu-unparsed-begin out (... ...)))]
[(block-context? ctx)
#'(honu-unparsed-begin out (... ...))]
(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 #'(honu-unparsed-expr out (... ...))])
[else (syntax/loc stx (out (... ...)))])
#;
#'(honu-unparsed-begin out (... ...))
#'rrest)
@ -422,9 +454,22 @@
#f obj 'obj #f ctx
out (... ...) rrest)
#;
#'rrest))])))
#'rrest))]))))
#'rest))]
[else (raise-syntax-error 'honu-macro "fail!")]
[(_ (m x ...)
(z y ...)
#;
(#%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))
#;
(printf "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 ...))

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

@ -3,11 +3,14 @@
(require "contexts.ss"
"util.ss"
(for-template "literals.ss"
"language.ss")
"language.ss"
"syntax.ss")
syntax/parse
syntax/parse/experimental/splicing
(for-syntax syntax/parse)
scheme/splicing
(for-syntax syntax/define)
syntax/name
syntax/stx
(for-syntax "util.ss")
(for-template scheme/base))
@ -40,8 +43,14 @@
#:attrs (result)
#:description "honu-expr"
(lambda (stx fail)
(printf "Honu expr ~a\n" stx)
(cond
[(stx-null? stx) (fail)]
[(syntax-parse stx #:literals (honu-syntax)
[(honu-syntax expr ...) #'(expr ...)]
[else #f]) => (lambda (exprs)
(printf "Ignoring honu-syntax 1!\n")
(list exprs 0 #''()))]
[(get-transformer stx) => (lambda (transformer)
(printf "Transforming honu macro ~a\n" (car stx))
(let-values ([(used rest)
@ -55,8 +64,14 @@
#:attributes (result)
#:description "honu-expr"
(lambda (stx fail)
(printf "Honu expr ~a\n" stx)
(cond
[(stx-null? stx) (fail)]
[(syntax-parse stx #:literals (honu-syntax)
[(honu-syntax expr ...) #'(expr ...)]
[else #f]) => (lambda (exprs)
(printf "Ignoring honu-syntax 2!\n")
(list '() 0 exprs))]
[(get-transformer stx) => (lambda (transformer)
(printf "Transforming honu macro ~a\n" (car stx))
(let-values ([(used rest)
@ -96,6 +111,7 @@
(define-splicing-syntax-class (do-rest context left)
(pattern (~seq (~var op operator-class)
(~var right (next context))
(~var new-right (do-rest context ((attribute op.func) left #'right.result))))
#:with result (attribute new-right.result))
(pattern (~seq) #:with result left))
@ -203,6 +219,26 @@
#:with result #'e.result])
(define (fix-output stx)
#|
(printf "Fix output ~a\n" stx)
(when (and (stx-pair? stx) (equal? 'syntax (syntax->datum (stx-car stx))))
(printf "syntax == honu-syntax? ~a\n" (free-identifier=? (stx-car stx) #'honu-syntax)))
|#
(syntax-parse stx #:literals (honu-syntax #%parens syntax)
[((honu-syntax (#%parens x ...) y ...) rest ...)
(with-syntax ([(y* ...) (fix-output #'(y ... rest ...))])
(syntax/loc stx
(x ... y* ...)))]
;; dont touch real syntax
[(syntax stuff ...) stx]
[(z x ...)
(with-syntax ([z* (fix-output #'z)]
[(x* ...) (fix-output #'(x ...))])
(syntax/loc stx
(z* x* ...)))]
[else stx]))
(define (parse-block-one/2 stx context)
(define (parse-one stx context)
@ -213,10 +249,30 @@
#;
[(x:number . rest) (values #'x #'rest)]
))
(printf "Parsing ~a\n" stx)
(cond
[(stx-null? stx) (values stx '())]
[(get-transformer stx) => (lambda (transformer)
(transformer stx context))]
(printf "Parse one: execute transformer ~a\n" transformer)
#;
(printf "output of transformer is ~a\n" (let-values ([(a b) (transformer stx context)]) (list a b)))
(call-values (transformer stx context)
(lambda (reparse rest)
(printf "Transformer gave us ~a\n" reparse)
#;
(values reparse rest)
#;
(values (fix-output reparse) rest)
#;
(printf "Macroized ~a and ~a\n" reparse rest)
(syntax-parse (fix-output reparse) #: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 reparse rest)]))
))]
[else (parse-one stx context)]))
(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref)
@ -230,7 +286,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))
@ -246,6 +301,8 @@
(make-honu-trans proc))
;; returns a transformer or #f
(define (get-transformer stx)
;; if its an identifier and bound to a transformer return it
@ -283,3 +340,14 @@
;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
(or (bound-transformer stx)
(special-transformer stx)))
#;
(define-honu-syntax honu-syntax
(lambda (stx ctx)
(syntax-case stx ()
[(_ expr ...)
(begin
(printf "Honu syntax on ~a\n" #'(expr ...))
(raise-syntax-error 'honu-syntax "should have been handled already")
#;
(parse-block-one/2 #'(expr ...) the-expression-context))])))

2
collects/honu/private/util.rkt
View File

@ -33,7 +33,7 @@
(loop (stx-cdr r) (cons (stx-car r) val-stxs))]))]
[(r ids) (extract-until r ids #f)]))
(define-syntax-rule (call-values function values-producing)
(define-syntax-rule (call-values values-producing function)
(call-with-values (lambda () values-producing) function))
;; shortcut for treating arguments as syntax objects