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

[honu] re-attach the output of macros to the input stream. wrap racket expressions so they dont get reparsed

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-01 18:14:05 -06:00
parent 3379fb8df6
commit b25406db4c
7 changed files with 92 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require "macro2.rkt" (require "macro2.rkt"
"literals.rkt"
(for-syntax racket/base (for-syntax racket/base
"literals.rkt" "literals.rkt"
"parse2.rkt" "parse2.rkt"
@ -22,21 +23,18 @@
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-method ...) . rest) [(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-method ...) . rest)
(define class (define class
#'(define name (class* object% () #'(%racket (define name (class* object% ()
(super-new) (super-new)
(init-field constructor-argument ...) (init-field constructor-argument ...)
method.result ...))) method.result ...))))
(values (values class #'rest #t)])))
class
#'rest
#t)])))
(provide honu-new) (provide honu-new)
(define-honu-syntax honu-new (define-honu-syntax honu-new
(lambda (code context) (lambda (code context)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens arg:honu-expression ...) . rest) [(_ name (#%parens arg:honu-expression ...) . rest)
(define new #'(make-object name arg.result ...)) (define new #'(%racket (make-object name arg.result ...)))
(values (values
new new
#'rest #'rest

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

@ -10,7 +10,9 @@
honu-then honu-then
honu-in honu-in
honu-prefix honu-prefix
semicolon) semicolon
%racket
%racket-expression)
(for-syntax syntax/parse (for-syntax syntax/parse
"literals.rkt" "literals.rkt"
"parse2.rkt" "parse2.rkt"
@ -26,10 +28,10 @@
(#%braces code ...) (#%braces code ...)
. rest) . rest)
(values (values
#'(lambda (arg ...) #'(%racket-expression (lambda (arg ...)
(let-syntax ([do-parse (lambda (stx) (let-syntax ([do-parse (lambda (stx)
(parse-all #'(code ...)))]) (parse-all #'(code ...)))])
(do-parse))) (do-parse))))
#'rest #'rest
#f)]))) #f)])))
@ -39,19 +41,8 @@
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
#:literals (honu-=) #:literals (honu-=)
[(_ name:id honu-= one:honu-expression . rest) [(_ name:id honu-= one:honu-expression . rest)
(values #'(define name one.result) (values #'(%racket (define name one.result))
#'rest #'rest
#t)
;; parse one expression
#;
(define-values (parsed unparsed)
(parse #'rest))
#;
(values
(with-syntax ([parsed parsed])
#'(define name parsed))
(with-syntax ([unparsed unparsed])
#'unparsed)
#t)]))) #t)])))
(provide honu-for) (provide honu-for)
@ -62,14 +53,14 @@
[(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression [(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression
honu-do body:honu-expression . rest) honu-do body:honu-expression . rest)
(values (values
#'(for ([iterator (in-range start.result end.result)]) #'(%racket (for ([iterator (in-range start.result end.result)])
body.result) body.result))
#'rest #'rest
#t)] #t)]
[(_ iterator:id honu-in stuff:honu-expression [(_ iterator:id honu-in stuff:honu-expression
honu-do body:honu-expression . rest) honu-do body:honu-expression . rest)
(values #'(for ([iterator stuff.result]) (values #'(%racket (for ([iterator stuff.result])
body.result) body.result))
#'rest #'rest
#t)]))) #t)])))
@ -80,7 +71,7 @@
#:literals (else honu-then) #:literals (else honu-then)
[(_ condition:honu-expression honu-then true:honu-expression else false:honu-expression . rest) [(_ condition:honu-expression honu-then true:honu-expression else false:honu-expression . rest)
(values (values
#'(if condition.result true.result false.result) #'(%racket-expression (if condition.result true.result false.result))
#'rest #'rest
#f)]))) #f)])))
@ -98,14 +89,14 @@
(lambda (code context) (lambda (code context)
(syntax-parse code (syntax-parse code
[(_ expression rest ...) [(_ expression rest ...)
(values #'(quote expression) #'(rest ...) #f)]))) (values #'(%racket-expression (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 #'(quasiquote expression) (values #'(%racket-expression (quasiquote expression))
#'(rest ...) #'(rest ...)
#f)]))) #f)])))
@ -138,14 +129,15 @@
(lambda (left right) (lambda (left right)
(with-syntax ([left left] (with-syntax ([left left]
[right right]) [right right])
#'(let ([left* left]) #'(%racket-expression
(let ([left* left])
(cond (cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)]) [(honu-struct? left*) (let ([use (honu-struct-get left*)])
(use left* 'right))] (use left* 'right))]
[(object? left*) (lambda args [(object? left*) (lambda args
(send/apply left* right args))] (send/apply left* right args))]
;; possibly handle other types of data ;; possibly handle other types of data
[else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))) [else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))))
(provide honu-flow) (provide honu-flow)
(define-honu-operator/syntax honu-flow 0.001 'left (define-honu-operator/syntax honu-flow 0.001 'left
@ -204,11 +196,11 @@
(syntax-parse code (syntax-parse code
[(_ form:require-form ... . rest) [(_ form:require-form ... . rest)
(values (values
#'(require (filtered-in (lambda (name) #'(%racket (require (filtered-in (lambda (name)
(regexp-replace* #rx"-" (regexp-replace* #rx"-"
(regexp-replace* #rx"->" name "_to_") (regexp-replace* #rx"->" name "_to_")
"_")) "_"))
(combine-in form.result ...))) (combine-in form.result ...))))
#'rest #'rest
#f)]))) #f)])))
@ -218,7 +210,7 @@
(lambda (code context) (lambda (code context)
(syntax-parse code #:literal-sets (cruft) (syntax-parse code #:literal-sets (cruft)
[(_ (#%parens name:id) something:honu-expression . rest) [(_ (#%parens name:id) something:honu-expression . rest)
(define with #'(with-input-from-file name (lambda () something.result))) (define with #'(%racket-expression (with-input-from-file name (lambda () something.result))))
(values (values
with with
#'rest #'rest

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

@ -29,7 +29,9 @@
honu-in honu-in
honu-for-syntax honu-for-syntax
honu-for-template honu-for-template
honu-prefix) honu-prefix
%racket
%racket-expression)
(define-syntax-rule (define-literal+set set literal ...) (define-syntax-rule (define-literal+set set literal ...)
(begin (begin
@ -37,4 +39,6 @@
(begin-for-syntax (begin-for-syntax
(define-literal-set set (literal ...))))) (define-literal-set set (literal ...)))))
(define-literal-set cruft (#%parens #%brackets #%braces semicolon colon honu-comma honu-<-)) (define-literal-set cruft (#%parens #%brackets #%braces
%racket %racket-expression
semicolon colon honu-comma honu-<-))

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

@ -174,33 +174,55 @@
;; parse one form ;; parse one form
;; return the parsed stuff and the unparsed stuff ;; return the parsed stuff and the unparsed stuff
(define (parse input) (define (parse input)
(define (do-macro head rest precedence left current stream)
(if current
(values (left current) stream)
(begin
(debug "Honu macro ~a\n" head)
(let-values ([(parsed unparsed terminate?)
((syntax-local-value head)
(with-syntax ([head head]
[(rest ...) rest])
#'(head rest ...))
#f)])
(with-syntax ([(parsed ...) parsed]
[(rest ...) unparsed])
(debug "Output from macro ~a\n" #'(parsed ...))
(do-parse #'(parsed ... rest ...)
precedence left current)
#;
(if terminate?
(values (left #'parsed)
#'rest)
(do-parse #'rest precedence
left #'parsed)))))))
(define (do-parse stream precedence left current) (define (do-parse stream precedence left current)
(define-syntax-class atom (define-syntax-class atom
[pattern x:identifier] [pattern x:identifier]
[pattern x:str] [pattern x:str]
[pattern x:number]) [pattern x:number])
(debug "parse ~a precedence ~a left ~a current ~a\n" stream precedence left current) (debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum stream) precedence left current)
(define final (if current current #f)) (define final (if current current #f))
(syntax-parse stream #:literal-sets (cruft) (syntax-parse stream #:literal-sets (cruft)
[() [()
(values (left final) #'())] (values (left final) #'())]
;; dont reparse pure racket code
[(%racket racket rest ...)
(if current
(values (left current) stream)
(values (left #'racket) #'(rest ...)))]
;; for expressions that can keep parsing
[(%racket-expression racket rest ...)
(if current
(values (left current) stream)
(do-parse #'(rest ...)
precedence left
#'racket))]
[(head rest ...) [(head rest ...)
(cond (cond
[(honu-macro? #'head) [(honu-macro? #'head)
(if current (do-macro #'head #'(rest ...) precedence left current stream)]
(values (left current) stream)
(begin
(debug "Honu macro ~a\n" #'head)
(let-values ([(parsed unparsed terminate?)
((syntax-local-value #'head) #'(head rest ...) #f)])
(with-syntax ([parsed parsed]
[rest unparsed])
(if terminate?
(values (left #'parsed)
#'rest)
(do-parse #'rest precedence
left #'parsed))))))]
[(parsed-syntax? #'head) [(parsed-syntax? #'head)
(do-parse #'(rest ...) precedence left #'head)] (do-parse #'(rest ...) precedence left #'head)]
[(honu-operator? #'head) [(honu-operator? #'head)

5
collects/honu/core/private/struct.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require "macro2.rkt" (require "macro2.rkt"
"literals.rkt"
(for-syntax racket/base (for-syntax racket/base
"parse2.rkt" "parse2.rkt"
"literals.rkt" "literals.rkt"
@ -23,12 +24,12 @@
(define out (define out
(with-syntax ([(fields.name/accessor ...) (with-syntax ([(fields.name/accessor ...)
(make-accessors #'name (syntax->list #'(fields.name ...)))]) (make-accessors #'name (syntax->list #'(fields.name ...)))])
#'(struct name (fields.name ...) #'(%racket (struct name (fields.name ...)
#:transparent #:transparent
#:property honu-struct (lambda (instance name) #:property honu-struct (lambda (instance name)
(case name (case name
[(fields.name) (fields.name/accessor instance)] [(fields.name) (fields.name/accessor instance)]
... ...
[else (error 'dot "no such field name ~a" name)]))))) [else (error 'dot "no such field name ~a" name)]))))))
(values out #'rest #t)]))) (values out #'rest #t)])))

6
collects/honu/private/common.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require honu/core/private/macro2 (require honu/core/private/macro2
honu/core/private/literals
(for-syntax syntax/parse (for-syntax syntax/parse
racket/base racket/base
honu/core/private/literals honu/core/private/literals
@ -16,7 +17,8 @@
[(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ... [(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ...
. rest) . rest)
(values (values
#'(cond #'(%racket-expression (cond
[clause.result body.result] ...) [clause.result body.result]
...))
#'rest #'rest
#t)]))) #t)])))

4
collects/tests/honu/linq.rkt
View File

@ -36,9 +36,9 @@
#'(sort store.result string<? #'(sort store.result string<?
#:key (lambda (name) order-by.result)) #:key (lambda (name) order-by.result))
#'store.result)]) #'store.result)])
#'(for/list ([name order] #'(%racket (for/list ([name order]
guard ...) guard ...)
select.result))) select.result))))
(values out #'rest #f)]))) (values out #'rest #f)])))
#| #|