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) (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 #'(%racket (make-object name arg.result ...))) (define new #'(make-object name arg.result ...))
(values (values
new new
#'rest #'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) (define-for-syntax (honu-compile forms)
#'(void)) #'(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) (define-syntax (honu-unparsed-begin stx)
(emit-remark "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)) (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 ;; 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 ;; so use an empty form, begin, `parsed' could be #f becuase there was no expression
;; in the input such as parsing just ";". ;; 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]) [(unparsed ...) unparsed])
(debug "Final parsed syntax ~a\n" (syntax->datum #'parsed))
(if (null? (syntax->datum #'(unparsed ...))) (if (null? (syntax->datum #'(unparsed ...)))
#'parsed #'parsed
#'(begin parsed (honu-unparsed-begin unparsed ...))))])) #'(begin parsed (honu-unparsed-begin unparsed ...))))]))

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

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

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

@ -10,7 +10,7 @@
(begin (begin
(define-syntax name (lambda (stx) (define-syntax name (lambda (stx)
(raise-syntax-error 'name (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) (define-literal honu-return)
@ -30,8 +30,7 @@
honu-for-syntax honu-for-syntax
honu-for-template honu-for-template
honu-prefix honu-prefix
%racket %racket)
%racket-expression)
(define-syntax-rule (define-literal+set set literal ...) (define-syntax-rule (define-literal+set set literal ...)
(begin (begin
@ -40,5 +39,5 @@
(define-literal-set set (literal ...))))) (define-literal-set set (literal ...)))))
(define-literal-set cruft (#%parens #%brackets #%braces (define-literal-set cruft (#%parens #%brackets #%braces
%racket %racket-expression %racket
semicolon colon honu-comma honu-<-)) semicolon colon honu-comma honu-<-))

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

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