From 3e96a1e66e9c23a4018c5413f9abd37ba8206504 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 13 Jul 2011 15:56:21 -0600 Subject: [PATCH] parse operators --- collects/honu/core/private/honu2.rkt | 8 ++++++ collects/honu/core/private/operator.rkt | 11 ++++++++ collects/honu/core/private/parse2.rkt | 29 ++++++++++++++++++++-- collects/honu/core/private/transformer.rkt | 26 +++++++++++++++++++ collects/tests/honu/test.rkt | 7 +++++- 5 files changed, 78 insertions(+), 3 deletions(-) create mode 100644 collects/honu/core/private/operator.rkt diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index c82ca3f298..535c0fa7fa 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "macro2.rkt" + "operator.rkt" (for-syntax syntax/parse "literals.rkt" "parse2.rkt" @@ -20,3 +21,10 @@ (parse #'(code ...)))]) (do-parse))) #'rest)]))) + +(provide honu-+) +(define-honu-operator/syntax honu-+ 1 + (lambda (left right) + (with-syntax ([left left] + [right right]) + #'(+ left right)))) diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt new file mode 100644 index 0000000000..a17d52020b --- /dev/null +++ b/collects/honu/core/private/operator.rkt @@ -0,0 +1,11 @@ +#lang racket/base + +(require (for-syntax racket/base + "transformer.rkt" + syntax/parse)) + +(provide define-honu-operator/syntax) +(define-syntax (define-honu-operator/syntax stx) + (syntax-parse stx + [(_ name precedence function) + #'(define-syntax name (make-honu-operator precedence function))])) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 1e211d45ce..14fb325aa4 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -42,6 +42,11 @@ (with-syntax ([check check]) #'(syntax-local-value check #'check (lambda () #f))))) +(define (bound-to-operator? check) + (let ([value (get-value check)]) + (debug "operator? ~a ~a\n" check value) + (transformer:honu-operator? value))) + (define (bound-to-macro? check) (let ([value (get-value check)]) (debug "macro? ~a ~a\n" check value) @@ -54,6 +59,10 @@ (and (identifier? something) (bound-to-macro? something))) +(define (honu-operator? something) + (and (identifier? something) + (bound-to-operator? something))) + (define (semicolon? what) (define-literal-set check (semicolon)) (and (identifier? what) @@ -81,16 +90,32 @@ current))]) parsed (more-parsing . rest)))))] + [(honu-operator? #'head) + (define new-precedence (transformer:honu-operator-ref (syntax-local-value #'head) 0)) + (define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 1)) + (define association 'left) + (define check + (case association + [(left) >] + [(right) >=])) + (printf "new precedence ~a\n" new-precedence) + (if (check new-precedence precedence) + (do-parse #'(rest ...) new-precedence + (lambda (stuff) + (operator-transformer left stuff)) + current) + (left current))] [(semicolon? #'head) (with-syntax ([so-far left]) #'(splicing-let-syntax ([more (lambda (stx) (parse #'(rest ...)))]) so-far (more)))] - [(identifier? #'head) (do-parse #'(rest ...) precedence #'head current)] [else (syntax-parse #'head #:literal-sets (cruft) + [x:number (do-parse #'(rest ...) + precedence (left #'x) current)] [(#%parens args ...) (debug "function call ~a\n" left) (with-syntax ([left left]) @@ -101,7 +126,7 @@ )])) - (do-parse input 0 #'(void) #'(void))) + (do-parse input 0 (lambda (x) x) #'(void))) (define (parse2 forms) (debug "parse forms ~a\n" forms) diff --git a/collects/honu/core/private/transformer.rkt b/collects/honu/core/private/transformer.rkt index 4b813eb855..756f98eaa5 100644 --- a/collects/honu/core/private/transformer.rkt +++ b/collects/honu/core/private/transformer.rkt @@ -2,8 +2,11 @@ (require (for-syntax racket/base)) +#; (provide (all-defined-out)) +(provide honu-transformer? make-honu-transformer) + (define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) (make-struct-type-property 'honu-transformer)) @@ -20,3 +23,26 @@ "procedure (arity 2)" proc)) (make-honu-trans proc)) + +(provide (rename-out [prop:honu-operator? honu-operator?]) + make-honu-operator + (rename-out [-honu-operator-ref honu-operator-ref])) +(define-values (prop:honu-operator prop:honu-operator? prop:honu-operator-ref) + (make-struct-type-property 'honu-operator)) + +#; +(provide honu-operator?) +(define-values (struct:honu-operator -make-honu-operator honu-operator? -honu-operator-ref honu-operator-set!) + (make-struct-type 'honu-operator #f 2 0 #f + (list (list prop:honu-operator #t)) + (current-inspector) 0)) + +(define (make-honu-operator precedence proc) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 2)) + (raise-type-error + 'define-honu-operator/syntax + "procedure (arity 2)" + proc)) + (-make-honu-operator precedence proc)) + diff --git a/collects/tests/honu/test.rkt b/collects/tests/honu/test.rkt index f29db3d786..c108443c61 100644 --- a/collects/tests/honu/test.rkt +++ b/collects/tests/honu/test.rkt @@ -3,7 +3,8 @@ (require (prefix-in macro_ honu/core/private/macro2) (rename-in honu/core/private/honu2 - [honu-function honu_function]) + [honu-function honu_function] + [honu-+ honu_plus]) (rename-in honu/core/private/literals [honu-= =] [semicolon |;|]) @@ -41,3 +42,7 @@ print(x) })) (test 5)) + + +(let () + (fake-module-begin #hx(1 honu_plus 1)))