From c8695ddf2e0412366b5bca62e7daa4938abb6bab Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Wed, 10 Aug 2011 10:14:15 -0600 Subject: [PATCH] [honu] set associativty for operators --- collects/honu/core/private/honu2.rkt | 24 ++++++++++++---------- collects/honu/core/private/operator.rkt | 4 ++-- collects/honu/core/private/parse2.rkt | 4 ++-- collects/honu/core/private/transformer.rkt | 6 +++--- collects/honu/core/read.rkt | 12 ++++++----- 5 files changed, 27 insertions(+), 23 deletions(-) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index b56b855bda..eef446ece3 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -73,22 +73,24 @@ (lambda (code context) (syntax-parse code [(_ expression rest ...) - (values #'(quasiquote expression) #'(rest ...) #f)]))) + (values #'(quasiquote expression) + #'(rest ...) + #f)]))) -(define-syntax-rule (define-binary-operator name precedence operator) +(define-syntax-rule (define-binary-operator name precedence associativity operator) (begin (provide name) - (define-honu-operator/syntax name precedence + (define-honu-operator/syntax name precedence associativity (lambda (left right) (with-syntax ([left left] [right right]) #'(operator left right)))))) -(define-binary-operator honu-+ 1 +) -(define-binary-operator honu-- 1 -) -(define-binary-operator honu-* 2 *) -(define-binary-operator honu-/ 2 /) -(define-binary-operator honu-^ 2 expt) -(define-binary-operator honu-and 0.5 and) -(define-binary-operator honu-or 0.5 or) -(define-binary-operator honu-cons 0.1 cons) +(define-binary-operator honu-+ 1 'left +) +(define-binary-operator honu-- 1 'left -) +(define-binary-operator honu-* 2 'left *) +(define-binary-operator honu-/ 2 'left /) +(define-binary-operator honu-^ 2 'right expt) +(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) diff --git a/collects/honu/core/private/operator.rkt b/collects/honu/core/private/operator.rkt index a17d52020b..c9b6226c2f 100644 --- a/collects/honu/core/private/operator.rkt +++ b/collects/honu/core/private/operator.rkt @@ -7,5 +7,5 @@ (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))])) + [(_ name precedence associativity function) + #'(define-syntax name (make-honu-operator precedence associativity function))])) diff --git a/collects/honu/core/private/parse2.rkt b/collects/honu/core/private/parse2.rkt index 08dc56b1a3..8da329072d 100644 --- a/collects/honu/core/private/parse2.rkt +++ b/collects/honu/core/private/parse2.rkt @@ -173,8 +173,8 @@ (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 association (transformer:honu-operator-ref (syntax-local-value #'head) 1)) + (define operator-transformer (transformer:honu-operator-ref (syntax-local-value #'head) 2)) (define higher (case association [(left) >] diff --git a/collects/honu/core/private/transformer.rkt b/collects/honu/core/private/transformer.rkt index 756f98eaa5..24ea25d069 100644 --- a/collects/honu/core/private/transformer.rkt +++ b/collects/honu/core/private/transformer.rkt @@ -33,16 +33,16 @@ #; (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 + (make-struct-type 'honu-operator #f 3 0 #f (list (list prop:honu-operator #t)) (current-inspector) 0)) -(define (make-honu-operator precedence proc) +(define (make-honu-operator precedence associativity 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)) + (-make-honu-operator precedence associativity proc)) diff --git a/collects/honu/core/read.rkt b/collects/honu/core/read.rkt index e1c7365b83..2603cb49bd 100644 --- a/collects/honu/core/read.rkt +++ b/collects/honu/core/read.rkt @@ -33,6 +33,7 @@ (define-lex-abbrev string-character (:or (:: #\\ any-char) (:~ #\"))) (define-lex-abbrev string (:: #\" (:* string-character) #\")) +(define-lex-abbrev operator (:or "+" "=" "*" "/" "-" "^")) (define-lex-abbrev block-comment (:: "/*" (complement (:: any-string "*/" any-string)) "*/")) @@ -68,10 +69,11 @@ ["!" (token-identifier '!)] ["'" (token-identifier 'quote)] ["`" (token-identifier 'quasiquote)] - ["=" (token-identifier '=)] - ["*" (token-identifier '*)] - ["/" (token-identifier '/)] - ["+" (token-identifier '+)] + ;; ["=" (token-identifier '=)] + [operator (token-identifier (string->symbol lexeme))] + ;; ["*" (token-identifier '*)] + ;; ["/" (token-identifier '/)] + ;; ["+" (token-identifier '+)] [";" (token-identifier '|;|)] ;; strip the quotes from the resulting string ;; TODO: find a more optimal way @@ -342,7 +344,7 @@ (define (do-parse current tokens table) (define (fail tokens) (if (null? tokens) - (error 'parse "error while parsing") + (error 'read "error while reading") (let ([first (car tokens)]) ;; hack to get the current failure behavior (do-parse current '() table)