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

[honu] wrap expressions with let so local macro parsers can be defined. replace more usages of %racket with racket-syntax

Browse Source
This commit is contained in:
Jon Rafkind 2012-02-21 16:18:50 -07:00
parent 7379684c5b
commit 4852904035
4 changed files with 34 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/honu/core/private/class.rkt
View File

@ -5,6 +5,7 @@
(only-in "operator.rkt" honu-equal) (only-in "operator.rkt" honu-equal)
(only-in "honu2.rkt" honu-declaration separate-ids) (only-in "honu2.rkt" honu-declaration separate-ids)
(for-syntax racket/base (for-syntax racket/base
"compile.rkt"
"literals.rkt" "literals.rkt"
"parse2.rkt" "parse2.rkt"
"util.rkt" "util.rkt"
@ -15,7 +16,7 @@
(define (replace-with-public method) (define (replace-with-public method)
(syntax-parse method #:literals (define) (syntax-parse method #:literals (define)
[(define (name args ...) body ...) [(define (name args ...) body ...)
#'(define/public (name args ...) body ...)])) (racket-syntax (define/public (name args ...) body ...))]))
(define-literal-set equals (honu-equal)) (define-literal-set equals (honu-equal))
(define-splicing-syntax-class honu-class-thing (define-splicing-syntax-class honu-class-thing
#:literal-sets (equals) #:literal-sets (equals)
@ -32,7 +33,7 @@
[(_ name (#%parens (~var constructor-argument (separate-ids (literal-syntax-class honu-comma) (literal-syntax-class honu-comma)))) [(_ name (#%parens (~var constructor-argument (separate-ids (literal-syntax-class honu-comma) (literal-syntax-class honu-comma))))
(#%braces method:honu-class-thing ...) . rest) (#%braces method:honu-class-thing ...) . rest)
(define class (define class
#'(%racket (define name (class* object% () (racket-syntax (define name (class* object% ()
(super-new) (super-new)
(init-field constructor-argument.id ...) (init-field constructor-argument.id ...)
method.result ...)))) method.result ...))))
@ -43,7 +44,7 @@
(lambda (code context) (lambda (code context)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens arg:honu-expression/comma) . rest) [(_ name (#%parens arg:honu-expression/comma) . rest)
(define new #'(%racket (make-object name arg.result ...))) (define new (racket-syntax (make-object name (let () arg.result) ...)))
(values (values
new new
(local-binding rest) (local-binding rest)

37
collects/honu/core/private/honu2.rkt
View File

@ -14,8 +14,7 @@
honu-prefix honu-prefix
semicolon semicolon
honu-comma honu-comma
define-literal define-literal)
%racket)
(for-syntax syntax/parse (for-syntax syntax/parse
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
syntax/parse/experimental/splicing syntax/parse/experimental/splicing
@ -49,14 +48,14 @@
[(_ name:identifier (#%parens (~seq arg:identifier (~optional honu-comma)) ...) [(_ name:identifier (#%parens (~seq arg:identifier (~optional honu-comma)) ...)
(#%braces code ...) . rest) (#%braces code ...) . rest)
(values (values
#'(%racket (define (name arg ...) (parse-body code ...))) (racket-syntax (define (name arg ...) (parse-body code ...)))
#'rest #'rest
#f)] #f)]
[(_ (#%parens (~seq arg:identifier (~optional honu-comma)) ...) [(_ (#%parens (~seq arg:identifier (~optional honu-comma)) ...)
(#%braces code ...) (#%braces code ...)
. rest) . rest)
(values (values
#'(%racket (lambda (arg ...) (racket-syntax (lambda (arg ...)
(parse-body code ...))) (parse-body code ...)))
#'rest #'rest
#f)]))) #f)])))
@ -69,7 +68,7 @@
[(_ (#%parens condition:honu-expression) true:honu-expression [(_ (#%parens condition:honu-expression) true:honu-expression
(~optional else) false:honu-expression . rest) (~optional else) false:honu-expression . rest)
(values (values
(racket-syntax (if condition.result true.result false.result)) (racket-syntax (if (let () condition.result) (let () true.result) (let () false.result)))
#'rest #'rest
#f)]))) #f)])))
@ -87,14 +86,14 @@
(lambda (code context) (lambda (code context)
(syntax-parse code (syntax-parse code
[(_ expression rest ...) [(_ expression rest ...)
(values #'(%racket (quote expression)) #'(rest ...) #f)]))) (values (racket-syntax (quote expression)) #'(rest ...) #f)])))
(provide honu-quasiquote) (provide honu-quasiquote)
(define-honu-syntax honu-quasiquote (define-honu-syntax honu-quasiquote
(lambda (code context) (lambda (code context)
(syntax-parse code (syntax-parse code
[(_ expression rest ...) [(_ expression rest ...)
(values #'(%racket (quasiquote expression)) (values (racket-syntax (quasiquote expression))
#'(rest ...) #'(rest ...)
#f)]))) #f)])))
@ -130,7 +129,7 @@
(debug "Parsed ~a unparsed ~a\n" parsed unparsed) (debug "Parsed ~a unparsed ~a\n" parsed unparsed)
(list (parsed-things stx unparsed) (list (parsed-things stx unparsed)
(with-syntax ([parsed parsed]) (with-syntax ([parsed parsed])
#'(%racket parsed))))) (racket-syntax parsed)))))
) ;; begin-for-syntax ) ;; begin-for-syntax
@ -140,7 +139,7 @@
(syntax-parse code (syntax-parse code
[(_ name:id level:number association:honu-expression function:honu-expression/phase+1 . rest) [(_ name:id level:number association:honu-expression function:honu-expression/phase+1 . rest)
(debug "Operator function ~a\n" (syntax->datum #'function.result)) (debug "Operator function ~a\n" (syntax->datum #'function.result))
(define out #'(%racket (define-honu-operator/syntax name level association.result function.result))) (define out (racket-syntax (define-honu-operator/syntax name level association.result function.result)))
(values out #'rest #t)]))) (values out #'rest #t)])))
(provide honu-dot) (provide honu-dot)
@ -152,7 +151,7 @@
#:literals (honu-equal) #:literals (honu-equal)
[pattern (_ name:identifier honu-equal argument:honu-expression . more) [pattern (_ name:identifier honu-equal argument:honu-expression . more)
#:with result (with-syntax ([left left]) #:with result (with-syntax ([left left])
#'(%racket (racket-syntax
(let ([left* left]) (let ([left* left])
(cond (cond
[(honu-struct? left*) [(honu-struct? left*)
@ -165,7 +164,7 @@
#:literals (honu-equal) #:literals (honu-equal)
[pattern (_ name:identifier . more) [pattern (_ name:identifier . more)
#:with result (with-syntax ([left left]) #:with result (with-syntax ([left left])
#'(%racket (racket-syntax
(let ([left* left]) (let ([left* left])
(cond (cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)]) [(honu-struct? left*) (let ([use (honu-struct-get left*)])
@ -184,7 +183,7 @@
(debug "dot left ~a right ~a\n" left right) (debug "dot left ~a right ~a\n" left right)
(with-syntax ([left left] (with-syntax ([left left]
[right right]) [right right])
#'(%racket (racket-syntax
(let ([left* left]) (let ([left* left])
(cond (cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)]) [(honu-struct? left*) (let ([use (honu-struct-get left*)])
@ -217,7 +216,7 @@
(syntax-parse code (syntax-parse code
[(_ form:require-form ... . rest) [(_ form:require-form ... . rest)
(values (values
#'(%racket (require (filtered-in (lambda (name) (racket-syntax (require (filtered-in (lambda (name)
(regexp-replace* #rx"-" (regexp-replace* #rx"-"
(regexp-replace* #rx"->" name "_to_") (regexp-replace* #rx"->" name "_to_")
"_")) "_"))
@ -240,7 +239,7 @@
(lambda (code context) (lambda (code context)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ file:honu-expression something:honu-expression . rest) [(_ file:honu-expression something:honu-expression . rest)
(define with #'(%racket (with-input-from-file file.result (define with (racket-syntax (with-input-from-file file.result
(lambda () something.result)))) (lambda () something.result))))
(values (values
with with
@ -253,7 +252,7 @@
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ condition:honu-expression body:honu-body . rest) [(_ condition:honu-expression body:honu-body . rest)
(values (values
#'(%racket (let loop () (racket-syntax (let loop ()
body.result body.result
(when condition.result (loop)))) (when condition.result (loop))))
#'rest #'rest
@ -277,7 +276,7 @@
#:literals (honu-with) #:literals (honu-with)
[(_ thing:honu-expression honu-with clause:match-clause ... . rest) [(_ thing:honu-expression honu-with clause:match-clause ... . rest)
(values (values
#'(%racket (match thing.result (racket-syntax (match thing.result
[clause.final clause.code] [clause.final clause.code]
...)) ...))
#'rest #'rest
@ -345,7 +344,7 @@
#:literals (honu-->) #:literals (honu-->)
[(_ (~seq name:id honu--> data:honu-expression (~optional honu-comma)) ... [(_ (~seq name:id honu--> data:honu-expression (~optional honu-comma)) ...
(#%braces code ...) . rest) (#%braces code ...) . rest)
(define out #'(%racket (with-syntax ([name data.result] ...) (define out (racket-syntax (with-syntax ([name data.result] ...)
(parse-body code ...)))) (parse-body code ...))))
(values out #'rest #t)]))) (values out #'rest #t)])))
@ -362,7 +361,7 @@
honu-do body:honu-expression . rest) honu-do body:honu-expression . rest)
(values (with-syntax ([(stuff.result ...) (map honu->racket (syntax->list #'(stuff.result ...)))] (values (with-syntax ([(stuff.result ...) (map honu->racket (syntax->list #'(stuff.result ...)))]
[body.result (honu->racket #'body.result)]) [body.result (honu->racket #'body.result)])
#'(%racket (for ([iterator stuff.result] ...) (racket-syntax (for ([iterator stuff.result] ...)
body.result))) body.result)))
#'rest #'rest
#t)]))) #t)])))
@ -383,7 +382,7 @@
[(_ (~seq init:id honu-equal init-expression:honu-expression (~optional honu-comma)) ... [(_ (~seq init:id honu-equal init-expression:honu-expression (~optional honu-comma)) ...
(~seq sequence:sequence-expression (~optional honu-comma)) ... (~seq sequence:sequence-expression (~optional honu-comma)) ...
honu-do body:honu-expression . rest) honu-do body:honu-expression . rest)
(values #'(%racket (for/fold ([init init-expression.result] ...) (values (racket-syntax (for/fold ([init init-expression.result] ...)
([sequence.variable sequence.expression] ...) ([sequence.variable sequence.expression] ...)
body.result)) body.result))
#'rest #'rest

7
collects/honu/core/private/operator.rkt
View File

@ -4,8 +4,7 @@
"transformer.rkt" "transformer.rkt"
"fixture.rkt" "fixture.rkt"
"compile.rkt" "compile.rkt"
syntax/parse) syntax/parse))
(only-in "literals.rkt" %racket))
(provide (all-defined-out)) (provide (all-defined-out))
@ -45,14 +44,14 @@
(lambda (left right) (lambda (left right)
(with-syntax ([left (honu->racket left)] (with-syntax ([left (honu->racket left)]
[right (honu->racket right)]) [right (honu->racket right)])
#'(%racket (right left))))) (racket-syntax (right left)))))
(begin-for-syntax (begin-for-syntax
(define-syntax-rule (mutator change) (define-syntax-rule (mutator change)
(lambda (left right) (lambda (left right)
(with-syntax ([left (honu->racket left)] (with-syntax ([left (honu->racket left)]
[right (change left (honu->racket right))]) [right (change left (honu->racket right))])
#'(%racket (set! left right)))))) (racket-syntax (set! left right))))))
;; Traditional assignment operator ;; Traditional assignment operator
(define-honu-operator/syntax honu-equal 0.0001 'left (define-honu-operator/syntax honu-equal 0.0001 'left

16
collects/honu/core/private/parse2.rkt
View File

@ -204,10 +204,12 @@
(define-syntax-class honu-body (define-syntax-class honu-body
#:literal-sets (cruft) #:literal-sets (cruft)
[pattern (#%braces code ...) [pattern (#%braces code ...)
#:with result #'(let () #:with result (racket-syntax (let ()
(define-syntax (parse-more stx) (define-syntax (parse-more stx)
(do-parse-rest stx #'parse-more)) (syntax-case stx ()
(parse-more code ...))]) [(_ stuff (... ...))
(do-parse-rest #'(stuff (... ...)) #'parse-more)]))
(parse-more code ...)))])
(provide honu-function) (provide honu-function)
(define-splicing-syntax-class honu-function #:literal-sets (cruft) (define-splicing-syntax-class honu-function #:literal-sets (cruft)
@ -215,8 +217,8 @@
#:with result #:with result
(with-syntax ([(parsed-arguments ...) (with-syntax ([(parsed-arguments ...)
(parse-arguments #'(args ...))]) (parse-arguments #'(args ...))])
#'(define (function parsed-arguments ...) (racket-syntax (define (function parsed-arguments ...)
body.result))]) body.result)))])
;; E = macro ;; E = macro
;; | E operator E ;; | E operator E
@ -495,7 +497,7 @@
(define call (with-syntax ([current (left current)] (define call (with-syntax ([current (left current)]
[(parsed-args ...) [(parsed-args ...)
(parse-comma-expression #'(args ...)) ]) (parse-comma-expression #'(args ...)) ])
#'(current parsed-args ...))) #'(current (let () parsed-args) ...)))
(do-parse #'(rest ...) 9000 (lambda (x) x) call)) (do-parse #'(rest ...) 9000 (lambda (x) x) call))
(let () (let ()
(debug 2 "function call ~a\n" left) (debug 2 "function call ~a\n" left)
@ -503,7 +505,7 @@
[(parsed-args ...) [(parsed-args ...)
(parse-comma-expression #'(args ...)) ]) (parse-comma-expression #'(args ...)) ])
(debug "Parsed args ~a\n" #'(parsed-args ...)) (debug "Parsed args ~a\n" #'(parsed-args ...))
#'(current parsed-args ...))) #'(current (let () parsed-args) ...)))
(do-parse #'(rest ...) precedence left call))) (do-parse #'(rest ...) precedence left call)))
(let () (let ()
(debug "inner expression ~a\n" #'(args ...)) (debug "inner expression ~a\n" #'(args ...))