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

[honu] use syntax properties to differentiate racket syntax from honu syntax instead of the %racket identifier

Browse Source
This commit is contained in:
Jon Rafkind 2012-02-21 14:15:39 -07:00
parent bb85c06df4
commit 7379684c5b
5 changed files with 112 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,7 +1,9 @@
#lang racket/base
(require syntax/parse
(for-syntax racket/base "debug.rkt" syntax/parse)
"debug.rkt"
(for-syntax racket/base "debug.rkt" syntax/parse
macro-debugger/emit)
"literals.rkt")
;; to get syntax as a literal
@ -11,9 +13,13 @@
(define (honu->racket forms)
(define-literal-set literals (%racket))
forms
#;
(syntax-parse forms #:literal-sets (literals)
#:literals ([literal-syntax syntax])
[(%racket x) (honu->racket #'x)]
[(%racket x) #'x
#;
(honu->racket #'x)]
[(literal-syntax form) #'#'form]
[(form ...)
(datum->syntax forms
@ -37,17 +43,20 @@
(define-syntax (unexpand-honu-syntax stx)
(define (remove-repeats input)
(debug "Remove repeats from ~a\n" (syntax->datum input))
(debug 2 "Remove repeats from ~a\n" (syntax->datum input))
(debug 2 "Properties ~a\n" (syntax-property-symbol-keys input))
(define-literal-set locals (repeat$))
(syntax-parse input #:literal-sets (locals)
[(out ... (repeat$ stuff ...) rest ...)
(debug " Found a repeat\n")
(debug 2 " Found a repeat\n")
(with-syntax ([(out* ...) (map remove-repeats (syntax->list #'(out ...)))]
[(rest* ...) (map remove-repeats (syntax->list #'(rest ...)))])
(remove-repeats #'(out* ... stuff ... rest* ...)))]
(remove-repeats (datum->syntax input
(syntax->list #'(out* ... stuff ... rest* ...))
input input)))]
[(normal ...) (with-syntax ([(normal* ...) (map remove-repeats (syntax->list #'(normal ...)))])
(datum->syntax input
#'(normal* ...)
(syntax->list #'(normal* ...))
input input))]
[x #'x]
[else (raise-syntax-error 'repeats "unhandled case" input)]))
@ -56,7 +65,32 @@
[(_ expr)
(begin
(debug "Expand honu syntax at phase ~a\n" (syntax-local-phase-level))
#;
(debug " Is ~a expanded ~a\n" (syntax->datum #'expr) (syntax->datum #'#'expr))
(emit-remark "Unexpand honu syntax" #'expr)
#;
(syntax-case #'expr ()
[(_ what) (debug "Properties on ~a are ~a\n" #'what (syntax-property-symbol-keys #'what))])
(define removed (remove-repeats #'expr))
(emit-local-step #'expr removed #:id #'unexpand-honu-syntax)
(debug "Cleansed ~a\n" (syntax->datum removed))
(debug "Syntax properties ~a\n" (syntax-property-symbol-keys removed))
removed)]))
; (define parsed-property (gensym 'honu-parsed))
(define parsed-property 'honu-parsed)
(define (parsed-syntax syntax)
(debug "Add parsed syntax property to ~a\n" syntax)
(if syntax
(syntax-property syntax parsed-property #t)
syntax))
(define (parsed-syntax? syntax)
(syntax-property syntax parsed-property))
(define-syntax (racket-syntax stx)
(syntax-case stx ()
[(_ form)
#'(parsed-syntax #'form)]))

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

@ -66,12 +66,10 @@
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (else honu-then)
[(_ (#%parens condition:honu-expression) true:honu-expression (~optional else) false:honu-expression . rest)
[(_ (#%parens condition:honu-expression) true:honu-expression
(~optional else) false:honu-expression . rest)
(values
(with-syntax ([condition.result (honu->racket #'condition.result)]
[true.result (honu->racket #'true.result)]
[false.result (honu->racket #'false.result)])
#'(%racket (if condition.result true.result false.result)))
(racket-syntax (if condition.result true.result false.result))
#'rest
#f)])))
@ -233,9 +231,9 @@
(lambda (code context)
(syntax-parse code
[(_ name:id ...)
(values #'(%racket (provide name ...))
#'()
#f)])))
(define out (parsed-syntax #'(provide name ...)))
(debug "Provide properties ~a\n" (syntax-property-symbol-keys out))
(values out #'() #f)])))
(provide honu-with-input-from-file)
(define-honu-syntax honu-with-input-from-file
@ -336,7 +334,8 @@
[(var:honu-declaration . rest)
(define result
(with-syntax ([var.expression (honu->racket #'var.expression)])
#'(%racket (define-values (var.name ...) var.expression))))
;; wrap the expression in a let so that we can insert new `define-syntax'es
(racket-syntax (define-values (var.name ...) (let () var.expression)))))
(values result #'rest #t)])))
(provide (rename-out [honu-with-syntax withSyntax]))
@ -361,8 +360,10 @@
#:literals (honu-in)
[(_ (~seq iterator:id honu-in stuff:honu-expression (~optional honu-comma)) ...
honu-do body:honu-expression . rest)
(values #'(%racket (for ([iterator stuff.result] ...)
body.result))
(values (with-syntax ([(stuff.result ...) (map honu->racket (syntax->list #'(stuff.result ...)))]
[body.result (honu->racket #'body.result)])
#'(%racket (for ([iterator stuff.result] ...)
body.result)))
#'rest
#t)])))

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

@ -12,10 +12,12 @@
racket/base)
(for-meta 2 syntax/parse
racket/base
macro-debugger/emit
"parse2.rkt"
"compile.rkt")
"literals.rkt"
"syntax.rkt"
"debug.rkt"
(for-meta -1 "literals.rkt" "compile.rkt" "parse2.rkt" "parse-helper.rkt")
#;
(for-syntax "honu-typed-scheme.rkt")
@ -106,6 +108,9 @@
(define-syntax (parse-stuff stx)
(syntax-parse stx
[(_ stuff ...)
(emit-remark "Parse stuff ~a\n" #'(stuff ...))
(parse-all #'(stuff ...))
#;
(honu->racket (parse-all #'(stuff ...)))])))
(provide honu-macro)
@ -132,7 +137,8 @@
(with-syntax ([name name]
[name.result (format-id name "~a_result" name)])
#'(name name.result)))])
#'(%racket (define-honu-syntax name
(racket-syntax
(define-honu-syntax name
(lambda (stx context-name)
(define-literal-set local-literals (literal ...))
(syntax-parse stx
@ -162,11 +168,14 @@
(syntax-parse stx #:literal-sets (local-literals)
[(honu-$ x ... honu-$ rest ...)
(with-syntax ([(rest* ...) (compress-dollars #'(rest ...))])
#'((repeat$ x ...) rest* ...))]
(datum->syntax stx (syntax->list #'((repeat$ x ...) rest* ...))
stx stx))]
[(x rest ...)
(with-syntax ([x* (compress-dollars #'x)]
[(rest* ...) (compress-dollars #'(rest ...))])
#'(x* rest* ...))]
(datum->syntax stx
(syntax->list #'(x* rest* ...))
stx stx))]
[x #'x]))
(syntax-parse code #:literal-sets (cruft)
[(_ (#%parens stuff ...) . rest)
@ -179,7 +188,7 @@
;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
(with-syntax ([(out ...) #'stuff*])
#'(%racket #'(%racket (unexpand-honu-syntax (do-parse-rest-macro out ...))))))
(racket-syntax #'stuff*)))
#; #'(%racket-expression (parse-stuff stuff ...))
#'rest
#f)])))
@ -188,9 +197,18 @@
;; #'(a b) + #'(c d) = #'(a b c d)
(provide mergeSyntax)
(define (mergeSyntax syntax1 syntax2)
(debug "Merge syntax ~a with ~a\n" (syntax->datum syntax1) (syntax->datum syntax2))
(with-syntax ([(syntax1* ...) syntax1]
[(syntax2* ...) syntax2])
#'(syntax1* ... syntax2* ...)))
#'(syntax1* ... syntax2* ...))
#;
(syntax-parse syntax1
[(r1 (unexpand something1))
(syntax-parse syntax2
[(r2 (unexpand2 something2))
(with-syntax ([(syntax1* ...) #'something1]
[(syntax2* ...) #'something2])
#'(%racket (unexpand (syntax1* ... syntax2* ...))))])]))
;; creates a new syntax/parse pattern
(provide honu-pattern)

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

@ -27,11 +27,11 @@
(lambda (left right)
(with-syntax ([left (honu->racket left)]
[right (honu->racket right)])
#'(%racket (operator left right))))
(racket-syntax (operator (let () left) (let () right)))))
;; unary
(lambda (argument)
(with-syntax ([argument (honu->racket argument)])
#'(%racket (operator argument))))))
(racket-syntax (operator (let () argument)))))))
(define-syntax-rule (define-unary-operator name precedence associativity operator)
(define-honu-operator/syntax name precedence associativity
@ -39,7 +39,7 @@
;; unary
(lambda (argument)
(with-syntax ([argument (honu->racket argument)])
#'(%racket (operator argument))))))
(racket-syntax (operator argument))))))
(define-honu-operator/syntax honu-flow 0.001 'left
(lambda (left right)

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

@ -24,6 +24,7 @@
(require (for-template racket/base
racket/splicing
(only-in "literals.rkt" %racket)
"compile.rkt"
"extra.rkt"))
(provide parse parse-all)
@ -138,15 +139,6 @@
(loop (cons parsed used)
unparsed))))))
(define parsed-property (gensym 'honu-parsed))
(define (parsed-syntax syntax)
(if syntax
(syntax-property syntax parsed-property #t)
syntax))
(define (parsed-syntax? syntax)
(syntax-property syntax parsed-property))
(define (stopper? what)
(define-literal-set check (honu-comma semicolon colon))
(define is (and (identifier? what)
@ -158,6 +150,7 @@
(define (do-parse-rest stx parse-more)
(syntax-parse stx
[(stuff ...)
(debug "Parse rest ~a\n" (syntax->datum #'(stuff ...)))
(define-values (parsed unparsed)
(parse (strip-stops #'(stuff ...))))
(debug "Parse more: ~a unparsed ~a\n" parsed unparsed)
@ -181,12 +174,23 @@
#'(define-syntax (name stx)
(syntax-case stx ()
[(_ stuff (... ...))
(debug "Properties on first element ~a\n" (syntax-property-symbol-keys (stx-car #'(stuff (... ...)))))
(do-parse-rest #'(stuff (... ...)) #'name)]))))
(with-syntax ([local local-parser]
#;
[parsed (do-parse-rest stx name)])
(with-syntax ([(stx ...) stx]
(with-syntax ([stx stx]
[name name])
#'(begin local (name stx ...)))))
(debug "Create local parser for ~a properties ~a\n" (syntax->datum #'stx) (syntax-property-symbol-keys #'stx))
;; sort of a hack, if the input is already parsed then don't deconstruct it
;; otherwise the input is a honu expression so we need to splice it in
(define with-local
(if (parsed-syntax? #'stx)
#'(begin local (unexpand-honu-syntax (name stx)))
(with-syntax ([(inside ...) #'stx])
#'(begin local (unexpand-honu-syntax (name inside ...))))))
(emit-local-step #'stx with-local #:id #'do-parse-rest/local)
(parsed-syntax with-local))))
#|
(provide do-parse-rest-macro)
@ -256,7 +260,8 @@
((syntax-local-value head)
(with-syntax ([head head]
[(rest ...) rest])
(datum->syntax #'head (syntax->list #'(head rest ...))
(datum->syntax #'head
(syntax->list #'(head rest ...))
#'head #'head))
#f)])
#;
@ -271,7 +276,8 @@
precedence left current)
(define re-parse
(with-syntax ([(x ...) #'parsed])
(do-parse-rest/local #'(x ...))))
(debug "Properties on parsed ~a\n" (syntax-property-symbol-keys #'parsed))
(do-parse-rest/local #'parsed)))
(debug "Reparsed ~a\n" (pretty-format (syntax->datum re-parse)))
#;
(define re-parse (let-values ([(re-parse re-unparse)
@ -287,6 +293,7 @@
(do-parse-rest stx #'parse-more))
(parse-more re-unparse* ...)))))
re-parse re-parse))))
#;
(debug "Reparsed output ~a\n" (pretty-format (syntax->datum re-parse)))
(if terminate?
(values (left re-parse)
@ -299,9 +306,12 @@
[pattern x:str]
[pattern x:number])
(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 properties ~a\n"
(syntax->datum stream) precedence left current
(syntax-property-symbol-keys stream))
(define final (if current current #f))
(if (parsed-syntax? stream)
(values (left stream) #'())
(syntax-parse stream #:literal-sets (cruft)
#;
[x:id (values #'x #'())]
@ -340,6 +350,7 @@
(do-macro #'head #'(rest ...) precedence left current stream)]
[(parsed-syntax? #'head)
(debug "Parsed syntax ~a\n" #'head)
(emit-local-step #'head #'head #:id #'do-parse)
(do-parse #'(rest ...) precedence left #'head)]
[(honu-fixture? #'head)
(debug 2 "Fixture ~a\n" #'head)
@ -419,7 +430,7 @@
[(left:no-left function:honu-function . rest)
(values #'function.result #'rest)]
[else
(debug "Parse a single thing ~a\n" #'head)
(debug "Parse a single thing ~a\n" (syntax->datum #'head))
(syntax-parse #'head
#:literal-sets (cruft)
[(%racket x)
@ -513,7 +524,7 @@
#'(current parsed-args ...))))
#;
(error 'parse "function call")]
[else (error 'what "dont know how to parse ~a" #'head)])])])]))
[else (error 'what "dont know how to parse ~a" #'head)])])])])))
(define-values (parsed unparsed)
(do-parse input 0 (lambda (x) x) #f))
@ -541,6 +552,7 @@
(with-syntax ([(use ...) (reverse (if parsed
(cons parsed all)
all))])
(emit-remark "Parsed all" #'(begin use ...))
#'(begin use ...))
(loop (cons parsed all)
unparsed))))
@ -561,8 +573,11 @@
(define-values (parsed unparsed)
(parse stx))
(debug "parsed ~a\n" (if parsed (syntax->datum parsed) parsed))
(list (parsed-things stx unparsed) (with-syntax ([parsed parsed])
#'(%racket parsed)))))
(list (parsed-things stx unparsed)
(parsed-syntax parsed)
#;
(with-syntax ([parsed parsed])
#'(%racket parsed)))))
(provide honu-identifier)
(define-splicing-syntax-class honu-identifier