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

[honu] redo operator parsing to fix various precedence cases. add a new quasi-operator macro that can consume as much input on the right as it wants and use that to call methods on objects. change = to equal?. allow variables to be defined in classes

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-14 00:41:21 -07:00
parent 870c8d28f4
commit 5cb1834376
12 changed files with 190 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/honu/core/main.rkt
View File

@ -5,13 +5,15 @@
"private/macro2.rkt"
(for-syntax (only-in "private/macro2.rkt" honu-syntax))
"private/class.rkt"
(for-syntax (only-in "private/parse2.rkt" honu-expression))
(for-syntax (prefix-in class: syntax/parse))
(for-syntax (only-in "private/parse2.rkt" honu-expression honu-identifier))
(prefix-in literal: "private/literals.rkt"))
(provide #%top
#%datum
print printf true false
(for-syntax (rename-out [honu-expression expression]
[honu-identifier identifier]
[honu-syntax syntax]))
(rename-out [#%dynamic-honu-module-begin #%module-begin]
[honu-top-interaction #%top-interaction]
@ -22,6 +24,9 @@
[honu-require require]
[honu-macro macro]
[honu-syntax syntax]
[honu-while while]
[honu-match match]
[honu-with with]
[honu-var var]
[honu-val val]
[honu-for for]
@ -30,15 +35,18 @@
[honu-quasiquote quasiquote]
[honu-+ +] [honu-- -]
[honu-* *] [honu-/ /]
[honu-modulo %]
[honu-^ ^]
[honu-> >] [honu-< <]
[honu->= >=] [honu-<= <=]
[honu-= =]
; [honu-= =]
[honu-equal =]
[honu-assignment :=]
[literal:honu-<- <-]
[honu-map map]
[honu-flow \|]
[honu-dot %dot]
[honu--> %arrow]
[honu-string=? string_equal]
[honu-cons ::]
[honu-and and] [honu-and &&]

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

@ -2,6 +2,7 @@
(require "macro2.rkt"
"literals.rkt"
(only-in "honu2.rkt" honu-var honu-equal)
(for-syntax racket/base
"literals.rkt"
"parse2.rkt"
@ -13,15 +14,18 @@
(syntax-parse method #:literals (define)
[(define (name args ...) body ...)
#'(define/public (name args ...) body ...)]))
(define-splicing-syntax-class honu-class-method
(define-splicing-syntax-class honu-class-thing
#:literals (honu-equal honu-var)
[pattern method:honu-function
#:with result (replace-with-public #'method.result)]))
#:with result (replace-with-public #'method.result)]
[pattern (~seq honu-var name:identifier honu-= out:honu-expression)
#:with result #'(field [name out.result])]))
(provide honu-class)
(define-honu-syntax honu-class
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-method ...) . rest)
[(_ name (#%parens constructor-argument ...) (#%braces method:honu-class-thing ...) . rest)
(define class
#'(%racket (define name (class* object% ()
(super-new)
@ -33,7 +37,7 @@
(define-honu-syntax honu-new
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ name (#%parens arg:honu-expression ...) . rest)
[(_ name (#%parens arg:honu-expression/comma) . rest)
(define new #'(%racket (make-object name arg.result ...)))
(values
new

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

@ -1,6 +1,7 @@
#lang racket/base
(require (for-syntax racket/base))
(require (for-syntax racket/base
syntax/parse))
(provide debug)
@ -34,8 +35,8 @@
(define-for-syntax verbose? (getenv "HONU_DEBUG"))
(define-syntax (debug stx)
(if verbose?
(syntax-case stx ()
[(_ str x ...)
(syntax-parse stx
[(_ str:str x ...)
(with-syntax ([file (filename (syntax-source #'str))]
[line (syntax-line #'str)]
[column (syntax-column #'str)])
@ -43,6 +44,11 @@
(colorize file 'green)
(colorize line 'red)
(colorize column 'red)
x ...))])
x ...))]
[(_ level:number message:str x ...)
(if (>= (string->number verbose?)
(syntax->datum #'level))
#'(debug message x ...)
#'(void))])
#'(void)))

26
collects/honu/core/private/fixture.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang racket/base
(require (for-syntax racket/base))
(provide (rename-out [prop:fixture? fixture?])
make-fixture
(rename-out [-fixture-ref fixture-ref]))
(define-values (prop:fixture prop:fixture? prop:fixture-ref)
(make-struct-type-property 'fixture))
#;
(provide honu-operator?)
(define-values (struct:fixture -make-fixture fixture? -fixture-ref fixture-set!)
(make-struct-type 'fixture #f 1 0 #f
(list (list prop:fixture #t))
(current-inspector) 0))
(define (make-fixture transformer)
(when (and (procedure? transformer)
(not (procedure-arity-includes? transformer 2)))
(raise-type-error
'define-fixture
"procedure (arity 2)"
transformer))
(-make-fixture transformer))

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

@ -16,7 +16,7 @@
"util.rkt"
"ops.rkt"
"syntax.rkt"
"parse.rkt"
;; "parse.rkt"
"parse2.rkt"
"literals.rkt"
)
@ -35,6 +35,7 @@
(begin-for-syntax
#;
(define parse-expr
;; The given syntax sequence must not be empty
(let ()
@ -209,6 +210,7 @@
parse-expr))
#;
(define (parse-tail-expr expr-stxs)
(syntax-parse expr-stxs
#:literals (honu-return)
@ -218,6 +220,7 @@
[else (parse-expr expr-stxs)]))
#;
(define (parse-block-one context body combine-k done-k)
(define (parse-one expr-stxs after-expr terminator)
(define (checks)
@ -254,6 +257,7 @@
))
parse-one )]))
#;
(define (parse-block stx ctx)
(let loop ([stx stx])
(parse-block-one ctx
@ -387,6 +391,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
(define (display2 x y)
(debug "~a ~a" x y))
#;
(define-syntax (honu-unparsed-expr stx)
(syntax-parse stx
[(_ expr ...)
@ -474,7 +479,7 @@ Then, in the pattern above for 'if', 'then' would be bound to the following synt
;; in the input such as parsing just ";".
(with-syntax ([parsed (if (not parsed) #'(begin) (honu->racket parsed))]
[(unparsed ...) unparsed])
(debug "Final parsed syntax ~a\n" (syntax->datum #'parsed))
(debug "Final parsed syntax\n~a\n" (pretty-format (syntax->datum #'parsed)))
(if (null? (syntax->datum #'(unparsed ...)))
#'parsed
#'(begin parsed (honu-unparsed-begin unparsed ...))))]))

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

@ -4,6 +4,7 @@
"operator.rkt"
"struct.rkt"
"honu-typed-scheme.rkt"
racket/match
racket/class
racket/require
(only-in "literals.rkt"
@ -11,8 +12,10 @@
honu-in
honu-prefix
semicolon
define-literal
%racket)
(for-syntax syntax/parse
racket/syntax
"debug.rkt"
"literals.rkt"
"parse2.rkt"
@ -39,8 +42,8 @@
(define-honu-syntax honu-var
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-=)
[(_ name:id honu-= one:honu-expression . rest)
#:literals (honu-equal)
[(_ name:id honu-equal one:honu-expression . rest)
(values #'(%racket (define name one.result))
#'rest
#t)])))
@ -49,8 +52,8 @@
(define-honu-syntax honu-for
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-= honu-in)
[(_ iterator:id honu-= start:honu-expression honu-to end:honu-expression
#:literals (honu-equal honu-in)
[(_ iterator:id honu-equal start:honu-expression honu-to end:honu-expression
honu-do body:honu-expression . rest)
(values
#'(%racket (for ([iterator (in-range start.result
@ -136,8 +139,7 @@
(cond
[(honu-struct? left*) (let ([use (honu-struct-get left*)])
(use left* 'right))]
[(object? left*) (lambda args
(send/apply left* right args))]
[(object? left*) (get-field right left*)]
;; possibly handle other types of data
[else (error 'dot "don't know how to deal with ~a (~a)" 'left left*)]))))))
@ -164,15 +166,18 @@
(define-binary-operator honu-<= 0.9 'left <=)
(define-binary-operator honu-> 0.9 'left >)
(define-binary-operator honu->= 0.9 'left >=)
(define-binary-operator honu-= 0.9 'left =)
;; (define-binary-operator honu-= 0.9 'left =)
(define-binary-operator honu-and 0.5 'left and)
(define-binary-operator honu-or 0.5 'left or)
(define-binary-operator honu-cons 0.1 'right cons)
(define-binary-operator honu-map 0.09 'left map)
(define-binary-operator honu-string=? 1 'left string=?)
(define-binary-operator honu-modulo 2 'left modulo)
(define-unary-operator honu-not 0.7 'left not)
(define-binary-operator honu-equal 1 'left equal?)
(provide honu-top-interaction)
(define-syntax (honu-top-interaction stx)
(syntax-case stx ()
@ -180,13 +185,17 @@
#'(#%top-interaction . (honu-unparsed-begin rest ...))]))
(begin-for-syntax
(define (fix-module-name name)
(format-id name "~a" (regexp-replace* #rx"_" (symbol->string (syntax->datum name)) "-")))
(define-splicing-syntax-class require-form
#:literals (honu-prefix)
#:literal-sets (cruft)
[pattern (~seq honu-prefix prefix module)
#:with result #'(prefix-in prefix module)]
#:with result (with-syntax ([module (fix-module-name #'module)])
#'(prefix-in prefix module))]
[pattern x:str #:with result #'x]
[pattern x:id #:with result #'x
[pattern x:id
#:with result (with-syntax ([name (fix-module-name #'x)]) #'name)
#:when (not ((literal-set->predicate cruft) #'x))]))
(define-for-syntax (racket-names->honu name)
@ -217,3 +226,44 @@
with
#'rest
#f)])))
(provide honu-while)
(define-honu-syntax honu-while
(lambda (code context)
(syntax-parse code #:literal-sets (cruft)
[(_ condition:honu-expression body:honu-body . rest)
(values
#'(%racket (let loop ()
body.result
(when condition.result (loop))))
#'rest
#t)])))
(provide honu-with honu-match)
(define-literal honu-with)
(define-honu-syntax honu-match
(lambda (code context)
(define-splicing-syntax-class match-clause
#:literal-sets (cruft)
[pattern (~seq (#%parens pattern ...)
body:honu-body)
#:with code #'body.result])
(syntax-parse code #:literal-sets (cruft)
#:literals (honu-with)
[(_ thing:honu-expression honu-with clause:match-clause ... . rest)
(values
#'(%racket (match thing.result
[(clause.pattern ...) clause.code]
...))
#'rest
#t)])))
(provide honu-->)
(define-honu-fixture honu-->
(lambda (left rest)
(syntax-parse rest #:literal-sets (cruft)
[(_ name:identifier (#%parens argument:honu-expression/comma) . more)
(with-syntax ([left left])
(values #'(send/apply left name (list argument.result ...))
#'more))])))

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

@ -16,7 +16,7 @@
(define-literal honu-return)
(define-literal semicolon)
(define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-%
honu-= honu-+= honu--= honu-*= honu-/= honu-%=
honu-+= honu--= honu-*= honu-/= honu-%=
honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>=
honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=
honu-!= honu-==

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

@ -2,6 +2,7 @@
(require (for-syntax racket/base
"transformer.rkt"
"fixture.rkt"
syntax/parse))
(provide define-honu-operator/syntax)
@ -11,3 +12,9 @@
#'(define-syntax name (make-honu-operator precedence associativity binary-function #f))]
[(_ name precedence associativity binary-function unary-function)
#'(define-syntax name (make-honu-operator precedence associativity binary-function unary-function))]))
(provide define-honu-fixture)
(define-syntax (define-honu-fixture stx)
(syntax-parse stx
[(_ name transformer)
#'(define-syntax name (make-fixture transformer))]))

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

@ -9,6 +9,7 @@
"debug.rkt"
"compile.rkt"
(prefix-in transformer: "transformer.rkt")
(prefix-in fixture: "fixture.rkt")
racket/pretty
syntax/stx
syntax/parse/experimental/splicing
@ -49,12 +50,17 @@
(define (bound-to-operator? check)
(let ([value (get-value check)])
(debug "operator? ~a ~a\n" check value)
(debug 2 "operator? ~a ~a\n" check value)
(transformer:honu-operator? value)))
(define (bound-to-fixture? check)
(let ([value (get-value check)])
(debug 2 "fixture? ~a ~a\n" check value)
(fixture:fixture? value)))
(define (bound-to-macro? check)
(let ([value (get-value check)])
(debug "macro? ~a ~a\n" check value)
(debug 2 "macro? ~a ~a\n" check value)
(transformer:honu-transformer? value))
#;
(let ([value (syntax-local-value check (lambda () #f))])
@ -68,6 +74,10 @@
(and (identifier? something)
(bound-to-operator? something)))
(define (honu-fixture? something)
(and (identifier? something)
(bound-to-fixture? something)))
(define (semicolon? what)
(define-literal-set check (semicolon))
(define is (and (identifier? what)
@ -79,7 +89,7 @@
(define-literal-set check (honu-comma))
(define is (and (identifier? what)
((literal-set->predicate check) what)))
(debug "Comma? ~a ~a\n" what is)
(debug 2 "Comma? ~a ~a\n" what is)
is)
(define-literal-set argument-stuff [honu-comma])
@ -137,7 +147,7 @@
(define-literal-set check (honu-comma semicolon colon))
(define is (and (identifier? what)
((literal-set->predicate check) what)))
(debug "Comma? ~a ~a\n" what is)
(debug 2 "Comma? ~a ~a\n" what is)
is)
(provide honu-function)
@ -254,6 +264,11 @@
(do-macro #'head #'(rest ...) precedence left current stream)]
[(parsed-syntax? #'head)
(do-parse #'(rest ...) precedence left #'head)]
[(honu-fixture? #'head)
(debug 2 "Fixture ~a\n" #'head)
(define transformer (fixture:fixture-ref (syntax-local-value #'head) 0))
(define-values (output rest) (transformer current stream))
(do-parse rest precedence left output)]
[(honu-operator? #'head)
(define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0))
(define association (transformer:honu-operator-ref (syntax-local-value #'head) 1))
@ -265,6 +280,20 @@
[(right) >=]))
(debug "precedence old ~a new ~a higher? ~a\n" precedence new-precedence (higher new-precedence precedence))
(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"))))
#f)])
(do-parse unparsed precedence left parsed))
#;
(do-parse #'(rest ...) new-precedence
(lambda (stuff)
(if current
@ -275,6 +304,8 @@
(left (unary-transformer stuff))
(error '#'head "cannot be used as a unary operator"))))
#f)
(values (left current) stream)
#;
(do-parse #'(head rest ...)
0
(lambda (x) x)
@ -284,6 +315,8 @@
(values (left final)
stream)]
[else
(define-splicing-syntax-class no-left
[pattern (~seq) #:when (not current)])
(syntax-parse #'(head rest ...) #:literal-sets (cruft)
[((semicolon more ...) . rest)
#;
@ -296,17 +329,8 @@
(when (not (stx-null? unparsed))
(raise-syntax-error 'parse "found unparsed input" unparsed))
(values (parse-all #'(more ...)) #'rest)]
[(function:honu-function . rest)
[(left:no-left function:honu-function . rest)
(values #'function.result #'rest)]
#;
[(function:identifier (#%parens args ...) (#%braces code ...) . rest)
(values (with-syntax ([(parsed-arguments ...)
(parse-arguments #'(args ...))])
#'(define (function parsed-arguments ...)
(let-syntax ([parse-more (lambda (stx)
(parse-all #'(code ...)))])
(parse-more))))
#'rest)]
[else (syntax-parse #'head
#:literal-sets (cruft)
[(%racket x)
@ -314,7 +338,7 @@
(values (left current) stream)
(do-parse #'(rest ...) precedence left #'head))]
[x:atom
(debug "atom ~a current ~a\n" #'x current)
(debug 2 "atom ~a current ~a\n" #'x current)
(if current
(values (left current) stream)
(do-parse #'(rest ...) precedence left #'x))]
@ -354,13 +378,14 @@
(if current
(if (> precedence 9000)
(let ()
(debug 2 "higher precedence call ~a\n" current)
(define call (with-syntax ([current (left current)]
[(parsed-args ...)
(parse-comma-expression #'(args ...)) ])
#'(current parsed-args ...)))
(do-parse #'(rest ...) 9000 (lambda (x) x) call))
(let ()
(debug "function call ~a\n" left)
(debug 2 "function call ~a\n" left)
(define call (with-syntax ([current current]
[(parsed-args ...)
(parse-comma-expression #'(args ...)) ])
@ -435,7 +460,23 @@
(list (parsed-things stx unparsed) (with-syntax ([parsed parsed])
#'(%racket parsed)))))
(provide honu-identifier)
(define-splicing-syntax-class honu-identifier
[pattern x:id #:with result #'x])
(provide identifier-comma-list)
(define-splicing-syntax-class identifier-comma-list
#:literal-sets (cruft)
[pattern (~seq (~seq name:id (~optional honu-comma)) ...)])
(provide honu-expression/comma)
(define-splicing-syntax-class honu-expression/comma
[pattern (~seq x ...) #:with (result ...) (parse-comma-expression #'(x ...))])
(provide honu-body)
(define-splicing-syntax-class honu-body
#:literal-sets (cruft)
[pattern (~seq (#%braces code ...))
#:with result #'(let-syntax ([parse-more (lambda (stx)
(honu->racket (parse-all #'(code ...))))])
(parse-more))])

5
collects/honu/core/read.rkt
View File

@ -36,8 +36,8 @@
(define-lex-abbrev string-character (:or (:: #\\ any-char)
(:~ #\")))
(define-lex-abbrev string (:: #\" (:* string-character) #\"))
(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^" "||" "|" "&&" "<="
">=" "<-" "<" ">" "!" "::" ":="))
(define-lex-abbrev operator (:or "+" "=" "==" "*" "/" "-" "^" "||" "|" "&&" "<="
">=" "<-" "<" ">" "!" "::" ":=" "%"))
(define-lex-abbrev block-comment (:: "/*"
(complement (:: any-string "*/" any-string))
"*/"))
@ -73,6 +73,7 @@
[":" (token-identifier '%colon)]
["'" (token-identifier 'quote)]
["`" (token-identifier 'quasiquote)]
["->" (token-identifier '%arrow)]
[operator (token-identifier (string->symbol lexeme))]
[";" (token-semicolon)]
;; strip the quotes from the resulting string

1
collects/honu/main.rkt
View File

@ -25,6 +25,7 @@
substring
(rename-out [honu-cond cond]
[null empty]
[current-inexact-milliseconds currentMilliseconds]
[string-length string_length]
[racket:empty? empty?]
[racket:first first]

1
collects/tests/honu/class.honu
View File

@ -1,6 +1,7 @@
#lang honu
class What(x){
var q = 2
foobar(z){
z + x
}