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

[honu] dont parse the output of syntax too early. wrap some core racket forms with %racket

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-08 14:10:58 -07:00
parent b25406db4c
commit 5aa6b0b06e
5 changed files with 76 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/honu/core/private/debug.rkt
View File

@ -9,6 +9,28 @@
(split-path (build-path path)))
name)
(define (colorize string color)
(define colors (hash 'none "0"
'black "0;30"
'red "0;31"
'green "0;32"
'brown "0;33"
'blue "0;34"
'purple "0;35"
'cyan "0;36"
'light-gray "0;37"
'dark-gray "1:30"
'light-red "1;31"
'light-green "1;32"
'yellow "1;33"
'light-blue "1;34"
'light-purple "1;35"
'light-cyan "1;36"
'white "1;37"))
(define (get-color color)
(hash-ref colors color (lambda () "0")))
(format "\033[~am~a\033[0m" (get-color color) string))
(define-for-syntax verbose? (getenv "HONU_DEBUG"))
(define-syntax (debug stx)
(if verbose?
@ -17,6 +39,10 @@
(with-syntax ([file (filename (syntax-source #'str))]
[line (syntax-line #'str)]
[column (syntax-column #'str)])
#'(printf (string-append "~a at ~a:~a " str) file line column x ...))])
#'(printf (string-append "~a at ~a:~a " str)
(colorize file 'green)
(colorize line 'red)
(colorize column 'red)
x ...))])
#'(void)))

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

@ -53,8 +53,12 @@
[(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression
honu-do body:honu-expression . rest)
(values
#'(%racket (for ([iterator (in-range start.result end.result)])
body.result))
(with-syntax ([start-parsed (parse-all #'start.result)]
[end-parsed (parse-all #'end.result)]
[body-parsed (parse-all #'body.result)])
#'(%racket (for ([iterator (in-range start-parsed
end-parsed)])
body-parsed)))
#'rest
#t)]
[(_ iterator:id honu-in stuff:honu-expression

36
collects/honu/core/private/macro2.rkt
View File

@ -8,6 +8,7 @@
"parse2.rkt"
"debug.rkt"
racket/base)
"literals.rkt"
syntax/parse)
(provide define-honu-syntax)
@ -37,18 +38,22 @@
(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)
(define what (parse-all (stx-cdr stx)))
(debug "Macro parse all ~a\n" what)
what)])
(do-parse action ...))
#'more
#t)]))))
(convert-pattern #'(pattern ...))])
#'(%racket (define-honu-syntax name
(lambda (stx context-name)
(syntax-parse stx
[(_ syntax-parse-pattern ... . more)
(define parsed (parse-all #'(action ...)))
(values parsed #'more #t)
#;
(values #'(%racket
(let-syntax ([do-parse (lambda (stx)
(define what (parse-all (stx-cdr stx)))
(debug "Macro parse all ~a\n" what)
what)])
(do-parse action ...)))
#'more
#t)])))))
#'rest
#t)])))
@ -58,19 +63,22 @@
(syntax-parse code #:literal-sets (cruft)
[(_ [#%brackets name:id data]
(#%braces code ...))
#'(with-syntax ([name data]) code ...)])))
#'(%racket-expression (with-syntax ([name data]) code ...))])))
#;
(define-syntax (parse-stuff stx)
(syntax-parse stx
[(_ stuff ...)
(parse-all #'(stuff ...))]))
(provide honu-syntax)
;; Do any honu-specific expansion here
(define-honu-syntax honu-syntax
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens stuff ...) . rest)
(values
#'(parse-stuff stuff ...)
#'(stuff ...)
#; #'(%racket-expression (parse-stuff stuff ...))
#'rest
#f)])))

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

@ -8,6 +8,7 @@
"literals.rkt"
"debug.rkt"
(prefix-in transformer: "transformer.rkt")
racket/pretty
syntax/stx
syntax/parse/experimental/splicing
syntax/parse)
@ -17,9 +18,10 @@
;; phase -1
(require (for-template racket/base
racket/splicing
(only-in "literals.rkt" %racket-expression)
"extra.rkt"))
(provide parse parse-all)
(provide parse parse-all parse-all)
#;
(define-literal-set literals
@ -148,6 +150,13 @@
(parse-all #'(code ...)))])
(parse-more))))])
;; E = macro
;; | E operator E
;; | [...]
;; | f(...)
;; | { ... }
;; | (...)
;; 1 + 1
;; ^
;; left: identity
@ -187,7 +196,7 @@
#f)])
(with-syntax ([(parsed ...) parsed]
[(rest ...) unparsed])
(debug "Output from macro ~a\n" #'(parsed ...))
(debug "Output from macro ~a\n" (pretty-format (syntax->datum #'(parsed ...))))
(do-parse #'(parsed ... rest ...)
precedence left current)
#;
@ -213,12 +222,18 @@
(values (left current) stream)
(values (left #'racket) #'(rest ...)))]
;; for expressions that can keep parsing
[(%racket-expression racket rest ...)
[((%racket-expression racket) rest ...)
(if current
(values (left current) stream)
(do-parse #'(rest ...)
precedence left
#'racket))]
[(%racket-expression racket)
(if current
(values (left current) stream)
(do-parse #'()
precedence left
#'racket))]
[(head rest ...)
(cond
[(honu-macro? #'head)
@ -397,7 +412,8 @@
(define-values (parsed unparsed)
(parse stx))
(debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed))
(list (parsed-things stx unparsed) parsed)))
(list (parsed-things stx unparsed) (with-syntax ([parsed parsed])
#'(%racket-expression parsed)))))
(provide identifier-comma-list)
(define-splicing-syntax-class identifier-comma-list

2
collects/tests/honu/macros.rkt
View File

@ -2,7 +2,7 @@
macro testx () {x:expression} {syntax(x_result + 1)}
testx 5 * 2;
testx 5 * 2
for z = 1 to testx 5 * 2 do
printf("z is ~a\n", z)