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

use literal sets

Browse Source
This commit is contained in:
Jon Rafkind 2010-06-02 17:21:02 -06:00
parent 99545f8a08
commit befa88f1ac
7 changed files with 77 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
collects/honu/main.rkt
View File

@ -17,6 +17,7 @@
(for-template "private/literals.rkt")
(for-syntax "private/more.ss")
(for-syntax "private/syntax.ss")
(for-syntax "private/macro.ss")
"private/macro.ss")
(define test-x-class
@ -26,7 +27,7 @@
(define x (new test-x-class [tuna 5]))
(define (sql1) #f)
(define (sql1 . x) #f)
(define (sql2) #f)
(define (sql3) #f)
(define (sql4) #f)
@ -63,12 +64,13 @@
with-syntax
quote
#%app
#%parens
#%parens #%brackets #%braces
...
map
syntax->list
identifier
expression
statement
(rename-out (semicolon \;
)
(ellipses-comma ec)
@ -76,6 +78,7 @@
#;
(honu-identifier identifier)
(expression-comma expression_comma)
(honu-macro macro)
(parse-an-expr parse)
(... scheme:...)
(honu-body:class body)
@ -84,6 +87,7 @@
(honu-+ +)
(honu-scheme scheme2)
(scheme-syntax scheme:syntax)
(scheme-syntax schemeSyntax)
))
#%braces #%parens #%brackets
x
@ -92,6 +96,10 @@
display
display2
newline
;; stuff i done want
define
let
;; end stuff
else
#%app
quote
@ -99,7 +107,10 @@
foobar2000
expression
str
(for-template #%parens)
define-struct
#;
(for-template #%parens #%brackets #%braces)
;; (for-meta 2 (rename-out (honu-syntax syntax)))
(rename-out
(honu-if if)
(honu-provide provide)

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

@ -13,6 +13,7 @@
"ops.ss"
"syntax.ss"
"parse.ss"
"literals.ss"
)
"literals.ss"
;; "typed-utils.ss"
@ -501,6 +502,15 @@ if (foo){
[(_ expr ...)
(parse-an-expr #'(expr ...))]))
(define-honu-syntax scheme-syntax
(lambda (body ctx)
(syntax-parse body
[(_ expr . rest)
(values
(lambda ()
(apply-scheme-syntax #'#'expr))
#'rest)])))
(define-honu-syntax honu-provide
(lambda (body ctx)
(syntax-parse body #:literals (semicolon)
@ -547,7 +557,7 @@ if (foo){
#'rest)])))
(define-syntax (honu-unparsed-begin stx)
(printf "honu unparsed begin: ~a\n" (syntax->datum stx))
(printf "honu unparsed begin: ~a at phase ~a\n" (syntax->datum stx) (syntax-local-phase-level))
(syntax-case stx ()
[(_) #'(void)]
[(_ . body)

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

@ -1,6 +1,7 @@
#lang racket
(provide (all-defined-out))
(require syntax/parse)
;; macro for defining literal tokens that can be used in macros
(define-syntax-rule (define-literal name ...)
@ -18,3 +19,5 @@
honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
honu-? honu-: honu-comma honu-. #%braces #%brackets #%parens colon
ellipses-comma ellipses-comma* ellipses-repeat honu-for-syntax)
(define-literal-set cruft (#%parens #%brackets #%braces semicolon))

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

@ -13,6 +13,7 @@
"contexts.ss"
"parse.ss"
"syntax.ss"
"literals.rkt"
"honu-typed-scheme.ss"
scheme/base
syntax/parse
@ -430,7 +431,8 @@
(define-honu-syntax honu-pattern
(lambda (stx ctx)
(syntax-parse stx #:literals (#%parens #%brackets semicolon)
(syntax-parse stx #:literal-sets ([cruft #:at stx])
;; #%parens #%brackets semicolon)
[(_ name (#%parens all-attributes:identifier ...) (#%brackets xpattern ...)
semicolon . rest)
(define my-parens (datum->syntax #'name '#%parens #'name #'name))
@ -445,28 +447,38 @@
[parens (datum->syntax #'name '#%parens #'name #'name)])
(syntax/loc stx
(define-splicing-syntax-class name
#:literals (parens)
#:literal-sets ([cruft #:at name])
#:attributes (all-attributes ...)
final-pattern))))
#'rest)])))
(define foobar 0)
(define-honu-syntax honu-macro
(lambda (stx ctx)
(define-syntax-class honu-macro3
#:literals (#%parens #%braces)
;; #:literals (#%parens #%braces)
#:literal-sets ([cruft ;;#:at stx
#:phase (syntax-local-phase-level)
])
[pattern (_ name (#%parens literals ...)
(#%braces template ...) (#%braces code ...)
. 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)])
#;
#'(define-honu-syntax name
(lambda (stx ctx)
(syntax-parse stx #:literals (your-parens literals ...)
(syntax-parse stx #:literals (your-parens your-bracket literals ...)
[(fixed ... rrest (... ...))
(values
#;
@ -481,7 +493,10 @@
(syntax/loc stx
(define-honu-syntax name
(lambda (stx ctx)
(syntax-parse stx #:literals (your-parens literals ...)
(printf "Executing macro `~a' on input `~a'\n" 'name (syntax->datum stx))
(syntax-parse stx
#:literal-sets ([cruft #:at name])
#:literals (foobar literals ...)
[(fixed ... rrest (... ...))
(values
#;
@ -595,7 +610,7 @@
#'rrest))]))))
#'rest))])
(printf "Executing honu macro\n")
(syntax-parse stx #:literals (#%parens #%braces)
(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)))]
[out:honu-macro2 (apply (lambda (a b) (values (lambda () a) b)) (syntax->list (attribute out.result)))]

2
collects/honu/private/more.ss
View File

@ -180,7 +180,7 @@
(define-syntax-rule (honu-syntax-maker maker unparsed)
(define-honu-syntax maker
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon #%parens)
(syntax-parse stx #:literal-sets ([cruft #:at unparsed])
[(_ (#%parens expr (... ...)) semicolon . rest)
(values
(lambda ()

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

@ -56,7 +56,7 @@
#:attrs (result)
#:description "honu-expr"
(lambda (stx fail)
(printf "Honu expr from transformer ~a in context ~a\n" (syntax->datum stx) context)
(printf "Honu expr from transformer `~a' in context ~a transformer ~a\n" (syntax->datum stx) context (get-transformer stx))
(cond
[(stx-null? stx) (fail)]
#;
@ -336,7 +336,7 @@
[pattern ((~var e (ternary context))
(~var x1 (debug-here (format "expression top 1 ~a\n" (syntax->datum #'e))))
semicolon
(~var x2 (debug-here "2"))
(~var x2 (debug-here "expression top 2"))
. rest)
#:with result #'e.result])
@ -432,6 +432,27 @@
[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 (printf "Whats at `~a': `~a'\n" hm #'x)
#f)])
(define-syntax-class statement
[pattern (~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)
#;
@ -454,7 +475,7 @@
(define (parse-an-expr stx)
(printf "Parse an expr ~a\n" (syntax->datum stx))
(syntax-parse (with-syntax ([(s ...) stx])
#'(s ... semicolon))
#'(s ...))
#;
[(raw:raw-scheme-syntax . rest) #'raw]
[((~var expr (expression-1 the-expression-context)) . rest) #'expr.result]
@ -555,10 +576,6 @@
(and (positive? (string-length str))
(memq (string-ref str 0) sym-chars)))))))
;; returns a transformer or #f
(define (get-transformer stx)
;; if its an identifier and bound to a transformer return it
@ -566,7 +583,6 @@
(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)))
(syntax-local-value (stx-car stx) (lambda () #f)))])
(and (honu-transformer? v) v))))
@ -596,8 +612,9 @@
(let ([v (syntax-local-value (stx-car first) (lambda () #f))])
(and (honu-transformer? v) v))]
[else #f]))))
#;
(printf "~a bound transformer? ~a\n" stx (bound-transformer stx))
(bound-transformer stx)
#;
(or (bound-transformer stx)
(special-transformer stx)))

1
collects/honu/private/syntax.ss
View File

@ -24,6 +24,7 @@
#;
(define honu-scheme-syntax (gensym))
#;
(define-syntax-rule (scheme-syntax stx)
(syntax-property (syntax stx) honu-scheme-syntax #t))