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

[honu] allow %racket expressions to remain inside honu syntax and remove them after parsing

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-10 11:57:45 -07:00
parent 961e280a98
commit 6b6ca7a7c3
6 changed files with 49 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -34,7 +34,7 @@
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens arg:honu-expression ...) . rest)
(define new #'(%racket (make-object name arg.result ...)))
(define new #'(make-object name arg.result ...))
(values
new
#'rest

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

@ -452,6 +452,17 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(define-for-syntax (honu-compile forms)
#'(void))
(define-for-syntax (honu->racket forms)
(define-literal-set literals (%racket))
;; (debug "honu to racket ~a\n" (pretty-format (syntax->datum forms)))
(syntax-parse forms #:literal-sets (literals)
[(%racket x) (honu->racket #'x)]
[(form ...)
(with-syntax ([(form* ...) (map honu->racket (syntax->list #'(form ...)))])
#'(form* ...))]
[x #'x]
[() forms]))
(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))
@ -465,8 +476,9 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
;; if parsed is #f then we don't want to expand to anything that will print
;; so use an empty form, begin, `parsed' could be #f becuase there was no expression
;; in the input such as parsing just ";".
(with-syntax ([parsed (if (not parsed) #'(begin) parsed)]
(with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))]
[(unparsed ...) unparsed])
(debug "Final parsed syntax ~a\n" (syntax->datum #'parsed))
(if (null? (syntax->datum #'(unparsed ...)))
#'parsed
#'(begin parsed (honu-unparsed-begin unparsed ...))))]))

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

@ -11,9 +11,9 @@
honu-in
honu-prefix
semicolon
%racket
%racket-expression)
%racket)
(for-syntax syntax/parse
"debug.rkt"
"literals.rkt"
"parse2.rkt"
racket/base))
@ -28,7 +28,7 @@
(#%braces code ...)
. rest)
(values
#'(%racket-expression (lambda (arg ...)
#'(%racket (lambda (arg ...)
(let-syntax ([do-parse (lambda (stx)
(parse-all #'(code ...)))])
(do-parse))))
@ -41,8 +41,7 @@
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-=)
[(_ name:id honu-= one:honu-expression . rest)
(values (with-syntax ([one-parsed (parse-all #'one.result)])
#'(%racket (define name one-parsed)))
(values #'(%racket (define name one.result))
#'rest
#t)])))
@ -54,12 +53,9 @@
[(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression
honu-do body:honu-expression . rest)
(values
(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)))
#'(%racket (for ([iterator (in-range start.result
end.result)])
body.result))
#'rest
#t)]
[(_ iterator:id honu-in stuff:honu-expression
@ -76,10 +72,7 @@
#:literals (else honu-then)
[(_ condition:honu-expression honu-then true:honu-expression else false:honu-expression . rest)
(values
(with-syntax ([condition-parsed (parse-all #'condition.result)]
[true-parsed (parse-all #'true.result)]
[false-parsed (parse-all #'false.result)])
#'(%racket-expression (if condition-parsed true-parsed false-parsed)))
#'(%racket (if condition.result true.result false.result))
#'rest
#f)])))
@ -97,14 +90,14 @@
(lambda (code context)
(syntax-parse code
[(_ expression rest ...)
(values #'(%racket-expression (quote expression)) #'(rest ...) #f)])))
(values #'(%racket (quote expression)) #'(rest ...) #f)])))
(provide honu-quasiquote)
(define-honu-syntax honu-quasiquote
(lambda (code context)
(syntax-parse code
[(_ expression rest ...)
(values #'(%racket-expression (quasiquote expression))
(values #'(%racket (quasiquote expression))
#'(rest ...)
#f)])))
@ -135,9 +128,10 @@
(provide honu-dot)
(define-honu-operator/syntax honu-dot 10000 'left
(lambda (left right)
(debug "dot left ~a right ~a\n" left right)
(with-syntax ([left left]
[right right])
#'(%racket-expression
#'(%racket
(let ([left* left])
(cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)])
@ -218,7 +212,7 @@
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens name:id) something:honu-expression . rest)
(define with #'(%racket-expression (with-input-from-file name (lambda () something.result))))
(define with #'(%racket (with-input-from-file name (lambda () something.result))))
(values
with
#'rest

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

@ -10,7 +10,7 @@
(begin
(define-syntax name (lambda (stx)
(raise-syntax-error 'name
"this is a literal and cannot be used outside a macro")))
"this is a literal and cannot be used outside a macro" (syntax->datum stx))))
...))
(define-literal honu-return)
@ -30,8 +30,7 @@
honu-for-syntax
honu-for-template
honu-prefix
%racket
%racket-expression)
%racket)
(define-syntax-rule (define-literal+set set literal ...)
(begin
@ -40,5 +39,5 @@
(define-literal-set set (literal ...)))))
(define-literal-set cruft (#%parens #%brackets #%braces
%racket %racket-expression
%racket
semicolon colon honu-comma honu-<-))

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

@ -18,10 +18,10 @@
;; phase -1
(require (for-template racket/base
racket/splicing
(only-in "literals.rkt" %racket-expression)
(only-in "literals.rkt" %racket)
"extra.rkt"))
(provide parse parse-all parse-all)
(provide parse parse-all)
#;
(define-literal-set literals
@ -194,12 +194,12 @@
[(rest ...) rest])
#'(head rest ...))
#f)])
(with-syntax ([(parsed ...) parsed]
[(rest ...) unparsed])
(debug "Output from macro ~a\n" (pretty-format (syntax->datum #'(parsed ...))))
(with-syntax ([parsed parsed]
[rest unparsed])
(debug "Output from macro ~a\n" (pretty-format (syntax->datum #'parsed)))
#;
(do-parse #'(parsed ... rest ...)
precedence left current)
#;
(if terminate?
(values (left #'parsed)
#'rest)
@ -214,20 +214,25 @@
(debug "parse ~a precedence ~a left ~a current ~a\n" (syntax->datum stream) precedence left current)
(define final (if current current #f))
(syntax-parse stream #:literal-sets (cruft)
#;
[x:id (values #'x #'())]
[()
(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))]
#;
[(%racket-expression racket rest ...)
(if current
(values (left current) stream)
@ -295,6 +300,10 @@
#'rest)]
[else (syntax-parse #'head
#:literal-sets (cruft)
[(%racket rest ...)
(if current
(values (left current) stream)
(do-parse #'(rest ...) precedence left #'head))]
[x:atom
(debug "atom ~a current ~a\n" #'x current)
(if current
@ -418,7 +427,7 @@
(parse stx))
(debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed))
(list (parsed-things stx unparsed) (with-syntax ([parsed parsed])
#'(%racket-expression parsed)))))
#'(%racket parsed)))))
(provide identifier-comma-list)
(define-splicing-syntax-class identifier-comma-list

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

@ -17,14 +17,8 @@
[(_ (~seq clause:honu-expression colon body:honu-expression (~optional honu-comma)) ...
. rest)
(values
(with-syntax ([(clause-parsed ...) (map (lambda (clause)
(parse-all clause))
(syntax->list #'(clause.result ...)))]
[(body-parsed ...) (map (lambda (body)
(parse-all body))
(syntax->list #'(body.result ...)))])
#'(%racket-expression (cond
[clause-parsed body-parsed]
...)))
#'(%racket (cond
[clause.result body.result]
...))
#'rest
#t)])))