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

start new honu implementation

Browse Source
This commit is contained in:
Jon Rafkind 2011-07-12 10:31:50 -06:00
parent 52527d8a95
commit 2737351c4a
14 changed files with 308 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/honu/core/main.rkt
View File

@ -17,10 +17,14 @@
"private/more.rkt"
(for-template racket/base)
(for-template "private/literals.rkt")
#;
(for-syntax "private/more.rkt")
#;
(for-syntax "private/syntax.rkt")
(prefix-in macro: "private/macro2.rkt")
#;
(for-syntax "private/macro.rkt")
"private/macro.rkt")
"private/macro.ss")
(define-for-syntax (syntax-to-string stx)
(format "original '~a' - ~a" (syntax->datum stx) (to-honu-string stx)))
@ -57,6 +61,7 @@
(honu-and and)
(honu-comma |,|)
(honu-. |.|)
[honu-var var]
(expression-comma expression_comma)
)
@ -85,15 +90,22 @@
(ellipses-repeat repeat)
(honu-identifier identifier)
(expression-comma expression_comma)
#;
(honu-macro macro)
(parse-an-expr parse)
(... scheme:...)
(honu-body:class body)
#;
(honu-syntax syntax)
#;
(honu-expression-syntax expressionSyntax)
#;
(honu-+ +)
#;
(honu-scheme scheme2)
#;
(scheme-syntax scheme:syntax)
#;
(scheme-syntax schemeSyntax)
))
#%braces #%parens #%brackets
@ -120,6 +132,7 @@
str
in-range
honu-struct
macro:macro
(rename-out
(struct scheme-struct)
(syntax real-syntax)
@ -127,15 +140,20 @@
(honu-if if)
(honu-provide provide)
(honu-macro-item macroItem)
#;
(honu-macro macro)
#;
(honu-infix-macro infixMacro)
(honu-identifier identifier)
(honu-identifier identifier123)
(honu-require require)
(honu-for-syntax forSyntax)
(honu-for-template forTemplate)
#;
(honu-syntax syntax)
#;
(honu-pattern pattern)
(honu-keywords keywords)
#;
(scheme-syntax scheme:syntax)
))

44
collects/honu/core/private/honu-typed-scheme.rkt
View File

@ -15,12 +15,15 @@
"ops.rkt"
"syntax.rkt"
"parse.rkt"
"parse2.rkt"
"literals.rkt"
)
syntax/parse
"literals.rkt"
"debug.rkt"
;; "typed-utils.rkt"
;; (prefix-in honu: "honu.rkt")
(prefix-in honu: "macro2.rkt")
;; "typed-utils.ss"
)
(require (for-meta 2 scheme/base "util.rkt"))
@ -283,13 +286,6 @@ 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-syntax (define-honu-infix-syntax stx)
(let-values ([(id rhs) (normalize-definition stx #'lambda #f)])
(with-syntax ([id id]
@ -297,8 +293,7 @@ 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-macro-item
(honu:define-honu-syntax honu-macro-item
(lambda (stx ctx)
(syntax-parse stx
#:literals (#%braces)
@ -307,7 +302,7 @@ 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
(honu:define-honu-syntax honu-scheme
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon)
[(_ template semicolon rest ...)
@ -315,7 +310,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
[else (raise-syntax-error 'scheme "need a semicolon probably" stx)]
)))
(define-honu-syntax honu-keywords
(honu:define-honu-syntax honu-keywords
(lambda (stx ctx)
(syntax-parse stx #:literals (semicolon)
[(_ keyword:honu-identifier ... semicolon . rest)
@ -326,7 +321,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
...))))
#'rest)])))
(define-honu-syntax honu-if
(honu:define-honu-syntax honu-if
(lambda (stx ctx)
(define (parse-complete-block stx)
;; (debug "Parsing complete block ~a\n" (syntax->datum stx))
@ -392,7 +387,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(parse-an-expr #'(expr ...))]
[else (raise-syntax-error 'honu-unparsed-expr "Invalid expression syntax" stx)]))
(define-honu-syntax scheme-syntax
(honu:define-honu-syntax scheme-syntax
(lambda (body ctx)
(syntax-parse body
[(_ template . rest)
@ -402,7 +397,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(apply-scheme-syntax #'#'template))
#'rest)])))
(define-honu-syntax honu-provide
(honu:define-honu-syntax honu-provide
(lambda (body ctx)
(syntax-parse body #:literals (semicolon)
[(_ x:honu-identifier ... semicolon . rest)
@ -412,7 +407,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
#'(provide x.x ...))
#'rest)])))
(define-honu-syntax honu-require
(honu:define-honu-syntax honu-require
(lambda (body ctx)
(define-syntax-class for-syntax-form
#:literals (#%parens honu-for-syntax)
@ -447,10 +442,25 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
body))
#'rest)])))
(define-for-syntax (honu-expand forms)
(parse forms))
(define-for-syntax (honu-compile forms)
#'(void))
(provide honu-var)
(honu:define-honu-syntax honu-var
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name:id honu-= anything . rest)
(values
#'(define name anything)
#'rest)])))
(define-syntax (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))
(honu-compile (honu-expand (stx-cdr stx))))
(define-syntax (#%dynamic-honu-module-begin stx)
(syntax-case stx ()

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

@ -25,4 +25,4 @@
honu-for-syntax
honu-for-template)
(define-literal-set cruft (#%parens #%brackets #%braces semicolon))
(define-literal-set cruft (#%parens #%brackets #%braces semicolon honu-=))

15
collects/honu/core/private/macro.rkt
View File

@ -2,8 +2,9 @@
(require "honu-typed-scheme.rkt"
"literals.rkt"
"parse.rkt"
"syntax.rkt"
"parse.ss"
"syntax.ss"
(prefix-in honu: "honu.rkt")
syntax/parse
(for-syntax macro-debugger/emit)
(for-meta 2 macro-debugger/emit
@ -22,6 +23,7 @@
scheme/pretty
scheme/trace))
#;
(provide (all-defined-out))
(define-syntax (ensure-defined stx)
@ -176,10 +178,9 @@
#'(x* ...))]
[else stx]))
(provide (for-syntax unpull))
(define-honu-syntax honu-pattern
(honu:define-honu-syntax honu-pattern
(lambda (stx ctx)
(syntax-parse stx #:literal-sets ([cruft #:at stx])
#:literals (honu-literal)
@ -211,7 +212,7 @@
final-pattern)))))
#'rest)])))
(define-honu-syntax honu-infix-macro
(honu:define-honu-syntax honu-infix-macro
(lambda (stx ctx)
(debug "Infix macro!\n")
(define-splicing-syntax-class patterns
@ -232,7 +233,7 @@
(with-syntax ()
(apply-scheme-syntax
(syntax/loc stx
(define-honu-infix-syntax name
(honu:define-honu-infix-syntax name
(lambda (stx ctx)
(debug "~a pattern is ~a\n" 'name '(pattern.fixed ... ...))
(syntax-parse stx
@ -268,7 +269,7 @@
[else (raise-syntax-error 'honu-macro "fail" stx)]
)))
(define-honu-syntax honu-macro
(honu:define-honu-syntax honu-macro
(lambda (stx ctx)
(define-splicing-syntax-class patterns
#:literal-sets ([cruft #:phase (syntax-local-phase-level)])

51
collects/honu/core/private/macro2.rkt Normal file
View File

@ -0,0 +1,51 @@
#lang racket/base
(require (for-syntax "transformer.rkt"
syntax/define
syntax/parse
"literals.rkt"
"parse2.rkt"
"debug.rkt"
racket/base)
syntax/parse)
(provide define-honu-syntax)
(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-for-syntax (convert-pattern pattern)
(syntax-parse pattern
[(name semicolon class)
#'(~var name class)]))
(provide macro)
(define-honu-syntax macro
(lambda (code context)
(debug "Macroize ~a\n" code)
(syntax-parse code #:literal-sets (cruft)
[(_ name literals (#%braces pattern ...) (#%braces action ...) . rest)
(debug "Pattern is ~a\n" #'(pattern ...))
(values
(with-syntax ([syntax-parse-pattern
(convert-pattern #'(pattern ...))])
#'(define-honu-syntax name
(lambda (stx context-name)
(syntax-parse stx
[(_ syntax-parse-pattern . more)
(values #'(let-syntax ([do-parse (lambda (stx)
(parse stx))])
(do-parse action ...))
#'more)]))))
#'rest)])))
(provide (rename-out [honu-with-syntax withSyntax]))
(define-honu-syntax honu-with-syntax
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ [#%brackets name:id data]
(#%braces code ...))
#'(with-syntax ([name data]) code ...)])))

4
collects/honu/core/private/more.rkt
View File

@ -1,5 +1,7 @@
#lang racket/base
#|
(require "honu-typed-scheme.rkt"
"literals.rkt"
syntax/parse
@ -178,3 +180,5 @@
(honu-syntax-maker honu-syntax honu-unparsed-begin)
(honu-syntax-maker honu-expression-syntax honu-unparsed-expr)
|#

122
collects/honu/core/private/parse2.rkt Normal file
View File

@ -0,0 +1,122 @@
#lang racket/base
(define-syntax-rule (require-syntax stuff ...)
(require (for-syntax stuff ...)))
;; phase 0
(require ;; "macro2.rkt"
"literals.rkt"
"debug.rkt"
(prefix-in transformer: "transformer.rkt")
syntax/stx
syntax/parse)
;; phase 1
(require-syntax racket/base)
;; phase -1
(require (for-template racket/base
racket/splicing))
(provide parse)
#;
(define-literal-set literals
[honu-macro])
(define (get-value what)
(syntax-local-value what (lambda () #f)))
#;
(define (get-value what)
(debug "what is ~a\n" what)
(with-syntax ([what what])
(let-syntax ([v (lambda (stx)
(debug "get ~a\n" #'what)
(with-syntax ([x (syntax-local-value #'what (lambda () #f))])
#'x))])
(v))))
#;
(define (get-value check)
(eval-syntax
(with-syntax ([check check])
#'(syntax-local-value check #'check (lambda () #f)))))
(define (bound-to-macro? check)
(let ([value (get-value check)])
(debug "macro? ~a ~a\n" check value)
(transformer:honu-transformer? value))
#;
(let ([value (syntax-local-value check (lambda () #f))])
(transformer:honu-transformer? value)))
(define (honu-macro? something)
(and (identifier? something)
(bound-to-macro? something)))
(define (semicolon? what)
(define-literal-set check (semicolon))
(and (identifier? what)
((literal-set->predicate check) what)))
(define (parse input)
(define (do-parse stream precedence left current)
(debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current)
(syntax-parse stream
[() #'(void)]
[(head rest ...)
(cond
[(honu-macro? #'head)
(begin
(debug "Honu macro ~a\n" #'head)
(let-values ([(parsed unparsed)
((syntax-local-value #'head) #'(head rest ...) #f)])
(with-syntax ([parsed parsed]
[rest unparsed])
(do-parse #'rest precedence #'parsed current)
#;
#'(splicing-let-syntax ([more-parsing (lambda (stx)
(do-parse (stx-cdr stx)
precedence left
current))])
parsed
(more-parsing . rest)))))]
[(semicolon? #'head)
(with-syntax ([so-far left])
#'(splicing-let-syntax ([more (lambda (stx)
(parse #'(rest ...)))])
so-far (more)))]
[(identifier? #'head)
(do-parse #'(rest ...) precedence #'head current)]
[else (syntax-parse #'head
#:literal-sets (cruft)
[(#%parens args ...)
(debug "function call ~a\n" left)
(with-syntax ([left left])
#'(left args ...))
#;
(error 'parse "function call")]
[else (error 'what "dont know ~a" #'head)])]
)]))
(do-parse input 0 #f #f))
(define (parse2 forms)
(debug "parse forms ~a\n" forms)
(when (stx-pair? forms)
(define head (stx-car forms))
(if (honu-macro? head)
(begin
(debug "honu macro ~a\n" head)
(let-values ([(parsed rest)
((syntax-local-value head) forms #f)])
(with-syntax ([parsed parsed]
[rest rest])
#'(splicing-let-syntax ([more-parsing (lambda (stx)
(debug "more parsing!!\n")
(parse stx))])
parsed
(more-parsing . rest)))))
#'(debug "regular parsing\n"))))

22
collects/honu/core/private/transformer.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang racket/base
(require (for-syntax racket/base))
(provide (all-defined-out))
(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))

12
collects/honu/private/with.honu
View File

@ -3,14 +3,20 @@
provide withSyntax;
macro withSyntax () {
_ [variable:identifier expr:expression] { b ... /* body:statement */ }; } {
[variable:identifier expr:expression] { b ... /* body:statement */ }; } {
primitiveWithSyntax [variable_result (datumToSyntax (syntax expr)
expr_result
(syntax expr)
(syntax expr))]
syntax(b ...)
/*
#sx scheme:syntax #sx
(with-syntax ([variable_result (datum->syntax (real-syntax expr) expr_result
(real-syntax expr)
(real-syntax expr))])
(honu-unparsed-begin b ...))
*/
}
// applySchemeSyntax(#sx(real-syntax (with-syntax ([variable_result expr_result]) (honu-unparsed-begin b ...))))

2
collects/tests/honu/function.honu
View File

@ -1,5 +1,6 @@
#lang honu
/*
provide function;
macro function ()
{ _ name:identifier (args:identifier ...) { body ... } }
@ -7,3 +8,4 @@ macro function ()
(honu-unparsed-begin body ...)) }
{ _ (args:identifier ...) { body ... }}
{ #sx scheme:syntax #sx(lambda (args_result ...) (honu-unparsed-begin body ...)) }
*/

2
collects/tests/honu/struct-patterns.honu
View File

@ -1,5 +1,7 @@
#lang honu
/*
provide structField;
pattern structField (name_result) [name:identifier];
*/

2
collects/tests/honu/struct-use.honu
View File

@ -1,5 +1,6 @@
#lang honu
/*
// require "struct.honu";
struct foo {a b c};
@ -10,3 +11,4 @@ y = 9;
// x = foo(1, 2, 3);
display(z.a);
*/

2
collects/tests/honu/struct.honu
View File

@ -1,5 +1,6 @@
#lang honu
/*
require (forSyntax "struct-patterns.honu");
provide struct;
@ -8,3 +9,4 @@ macro struct () {
} {
schemeSyntax#sx(honu-struct name (field_name_result ...))
}
*/

37
collects/tests/honu/test.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/base
(require
"test1.rkt"
(prefix-in macro_ "macro2.rkt")
(rename-in "literals.rkt"
[honu-= =]
[semicolon |;|])
(rename-in (only-in "honu-typed-scheme.rkt" honu-var)
[honu-var var])
(for-syntax racket/base
"test1.rkt"
"macro2.rkt"
syntax/stx
racket/port
syntax/parse
(prefix-in parse: "parse2.rkt"))
racket/port)
(define-syntax (fake-module-begin stx)
(syntax-case stx ()
[(_ stuff)
(let ()
(define output (parse:parse (stx-cdr #'stuff)))
(printf "Output: ~a\n" (syntax->datum output))
output)]))
#;
(fake-module-begin #hx(macro_macro foo (){ x:number }{
withSyntax [z 5]{
syntax(print(x); print(z););
}
}
foo 5))
(fake-module-begin #hx(var x = 2;
print(x)))