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

[honu] create a new syntax class for parsing expressions at current-phase + 1. allow new operators to be defined using honu syntax

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-17 23:27:11 -07:00
parent b93486ed69
commit 70589a7033
7 changed files with 154 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,18 +1,18 @@
#lang racket/base
(require syntax/parse
"literals.rkt"
(for-template racket/base))
"literals.rkt")
(provide honu->racket)
(define (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* ...))]
(datum->syntax forms
(map honu->racket (syntax->list #'(form ...)))
forms
forms)]
[x #'x]
[() forms]))

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

@ -28,8 +28,8 @@
;; "typed-utils.ss"
)
(require (for-meta 2 scheme/base "util.rkt"))
(require (for-meta 3 scheme/base))
(require (for-meta 2 racket/base "util.rkt"))
(require (for-meta 3 racket/base))
(provide (all-defined-out))

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

@ -17,15 +17,30 @@
%racket)
(for-syntax syntax/parse
syntax/parse/experimental/reflect
syntax/parse/experimental/splicing
racket/syntax
racket/pretty
"compile.rkt"
"util.rkt"
"debug.rkt"
"literals.rkt"
"parse2.rkt"
racket/base))
racket/base)
(for-meta 2 racket/base
syntax/parse
racket/pretty
macro-debugger/emit
"compile.rkt"
"debug.rkt"
"parse2.rkt"))
(provide (all-from-out "struct.rkt"))
(define-syntax (parse-body stx)
(syntax-parse stx
[(_ stuff ...)
(honu->racket (parse-all #'(stuff ...)))]))
(provide honu-function)
(define-honu-syntax honu-function
(lambda (code context)
@ -35,9 +50,7 @@
. rest)
(values
#'(%racket (lambda (arg ...)
(let-syntax ([do-parse (lambda (stx)
(parse-all #'(code ...)))])
(do-parse))))
(parse-body code ...)))
#'rest
#f)])))
@ -105,11 +118,11 @@
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(operator left right)))
#'(%racket (operator left right))))
;; unary
(lambda (argument)
(with-syntax ([argument argument])
#'(operator argument))))))
#'(%racket (operator argument)))))))
(define-syntax-rule (define-unary-operator name precedence associativity operator)
(begin
@ -119,7 +132,51 @@
;; unary
(lambda (argument)
(with-syntax ([argument argument])
#'(operator argument))))))
#'(%racket (operator argument)))))))
(begin-for-syntax
(define-syntax (parse-expression stx)
(syntax-parse stx
[(_ (syntax-ignore (stuff ...)))
(debug "Parse expression ~a\n" (pretty-format (syntax->datum #'(stuff ...))))
(define-values (parsed unparsed)
(parse #'(stuff ...)))
(with-syntax ([parsed* (honu->racket parsed)]
[unparsed unparsed])
(emit-local-step parsed #'parsed* #:id #'honu-parse-expression)
(debug "Parsed ~a. Unparsed ~a\n" #'parsed #'unparsed)
;; we need to smuggle our parsed syntaxes through the macro transformer
#'(#%datum parsed* unparsed))]))
(define-primitive-splicing-syntax-class (honu-expression/phase+1)
#:attributes (result)
#:description "expression at phase + 1"
(lambda (stx fail)
(debug "honu expression phase + 1: ~a\n" (pretty-format (syntax->datum stx)))
(define transformed
(with-syntax ([stx stx])
(local-transformer-expand #'(parse-expression #'stx)
'expression '())))
(debug "Transformed ~a\n" (pretty-format (syntax->datum transformed)))
(define-values (parsed unparsed)
(syntax-parse transformed
[(ignore-quote (parsed unparsed)) (values #'parsed
#'unparsed)]))
(debug "Parsed ~a unparsed ~a\n" parsed unparsed)
(list (parsed-things stx unparsed)
(with-syntax ([parsed parsed])
#'(%racket parsed)))))
) ;; begin-for-syntax
(provide define-make-honu-operator)
(define-honu-syntax define-make-honu-operator
(lambda (code context)
(syntax-parse code
[(_ name:id level:number association:honu-expression function:honu-expression/phase+1 . rest)
(debug "Operator function ~a\n" (syntax->datum #'function.result))
(define out #'(%racket (define-honu-operator/syntax name level association.result function.result)))
(values out #'rest #t)])))
(provide honu-dot)
(define-honu-operator/syntax honu-dot 10000 'left
@ -141,14 +198,14 @@
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(right left))))
#'(%racket (right left)))))
(provide honu-assignment)
(define-honu-operator/syntax honu-assignment 0.0001 'left
(lambda (left right)
(with-syntax ([left left]
[right right])
#'(set! left right))))
#'(%racket (set! left right)))))
(define-binary-operator honu-+ 1 'left +)
(define-binary-operator honu-- 1 'left -)
@ -308,3 +365,14 @@
(define result #'(%racket (define-values (var.name ...) var.expression)))
(values result #'rest #t)])))
(provide (rename-out [honu-with-syntax withSyntax]))
(define-honu-syntax honu-with-syntax
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-->)
[(_ (~seq name:id honu--> data:honu-expression (~optional honu-comma)) ...
(#%braces code ...) . rest)
(define out #'(%racket (with-syntax ([name data.result] ...)
(parse-body code ...))))
(values out #'rest #t)])))

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

@ -8,6 +8,7 @@
"literals.rkt"
"parse2.rkt"
"debug.rkt"
"compile.rkt"
racket/base)
"literals.rkt"
#;
@ -44,6 +45,11 @@
[(thing:pattern-type ...)
(filter (lambda (x) (syntax-e x)) (syntax->list #'(thing.result ...)))]))
(define-syntax (parse-stuff stx)
(syntax-parse stx
[(_ stuff ...)
(honu->racket (parse-all #'(stuff ...)))]))
(provide honu-macro)
(define-honu-syntax honu-macro
(lambda (code context)
@ -56,8 +62,7 @@
(with-syntax ([(syntax-parse-pattern ...)
(convert-pattern #'(pattern ...))]
[((pattern-variable.name pattern-variable.result) ...)
(find-pattern-variables #'(pattern ...))]
[(code ...) (parse-all #'(action ...))])
(find-pattern-variables #'(pattern ...))])
#'(%racket (define-honu-syntax name
(lambda (stx context-name)
(syntax-parse stx
@ -69,33 +74,35 @@
;; instead of x_result. x_result is still there, too
(with-syntax ([pattern-variable.name #'pattern-variable.result]
...)
(code ...))
(parse-stuff action ...)
#;
(let-syntax ([parse-more (lambda (stx)
(parse-all #'(action ...)))])
(parse-more)))
#'more #t)])))))
#'rest
#t)])))
(provide (rename-out [honu-with-syntax withSyntax]))
(define-honu-syntax honu-with-syntax
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ [#%brackets name:id data]
(#%braces code ...))
#'(%racket (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)
(define context (stx-car #'(stuff ...)))
(values
#'(%racket #'(stuff ...))
(with-syntax ([stuff* (datum->syntax context
(syntax->list #'(stuff ...))
context context)])
#'(%racket #'stuff*))
#; #'(%racket-expression (parse-stuff stuff ...))
#'rest
#f)])))
;; combine syntax objects
;; #'(a b) + #'(c d) = #'(a b c d)
(provide mergeSyntax)
(define (mergeSyntax syntax1 syntax2)
(with-syntax ([(syntax1* ...) syntax1]
[(syntax2* ...) syntax2])
#'(syntax1* ... syntax2* ...)))

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

@ -10,12 +10,14 @@
"compile.rkt"
(prefix-in transformer: "transformer.rkt")
(prefix-in fixture: "fixture.rkt")
macro-debugger/emit
racket/pretty
syntax/stx
syntax/parse/experimental/splicing
syntax/parse)
;; phase 1
(require-syntax racket/base)
(require-syntax racket/base
"debug.rkt")
;; phase -1
(require (for-template racket/base
@ -158,6 +160,8 @@
(parse-arguments #'(args ...))])
#'(define (function parsed-arguments ...)
(let-syntax ([parse-more (lambda (stx)
;; this adds an extra mark, you might not
;; want that
(honu->racket (parse-all #'(code ...))))])
(parse-more))))])
@ -198,13 +202,17 @@
(if current
(values (left current) stream)
(begin
(debug "Honu macro ~a\n" head)
(debug "Honu macro at phase ~a: ~a\n" (syntax-local-phase-level) head)
(let-values ([(parsed unparsed terminate?)
((syntax-local-value head)
(with-syntax ([head head]
[(rest ...) rest])
#'(head rest ...))
(datum->syntax #'head (syntax->list #'(head rest ...))
#'head #'head))
#f)])
(emit-remark parsed)
#;
(emit-local-step stream parsed #:id #'do-macro)
(with-syntax ([parsed parsed]
[rest unparsed])
(debug "Output from macro ~a\n" (pretty-format (syntax->datum #'parsed)))
@ -215,7 +223,9 @@
(parse #'parsed)])
(with-syntax ([(re-parse* ...) re-parse]
[(re-unparse* ...) re-unparse])
#'(re-parse* ... re-unparse* ...))))
(datum->syntax re-parse
(syntax->list #'(re-parse* ... re-unparse* ...))
re-parse re-parse))))
(if terminate?
(values (left re-parse)
#'rest)
@ -282,14 +292,19 @@
(if (higher new-precedence precedence)
(let-values ([(parsed unparsed)
(do-parse #'(rest ...) new-precedence
(lambda (stuff)
(if current
(if binary-transformer
(binary-transformer current stuff)
(error '#'head "cannot be used as a binary operator"))
(if unary-transformer
(unary-transformer stuff)
(error '#'head "cannot be used as a unary operator"))))
(lambda (stuff)
(define output
(if current
(if binary-transformer
(binary-transformer current stuff)
(error '#'head "cannot be used as a binary operator"))
(if unary-transformer
(unary-transformer stuff)
(error '#'head "cannot be used as a unary operator"))))
(emit-local-step stuff output #:id #'binary-transformer)
(with-syntax ([out (parse-all output)])
#'(%racket out)))
#f)])
(do-parse unparsed precedence left parsed))
@ -442,6 +457,7 @@
(loop (cons parsed all)
unparsed))))
(provide parsed-things)
;; rest will be some subset of full
(define (parsed-things full rest)
(define full-datum (syntax->datum full))
@ -480,3 +496,4 @@
#:with result #'(let-syntax ([parse-more (lambda (stx)
(honu->racket (parse-all #'(code ...))))])
(parse-more))])

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

@ -1,6 +1,10 @@
#lang honu
macro testx () {x:expression} {syntax(x + 1)}
macro testx () {x:expression} {
var out1 = syntax(x)
var out2 = syntax(+ 1)
mergeSyntax(out1, out2)
}
testx 5 * 2

11
collects/tests/honu/operators.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang honu
operator gg 2 'left
function(left right){
withSyntax left -> left,
right -> right {
syntax(left * 2 - right)
}
}
3 gg 4 gg 5