From 17cf997b4fe8299daa8d40ba5077e3bb3af1d570 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Thu, 12 Sep 2024 02:19:43 +0900 Subject: Add direction configuration to rule-set --- qklib/infix.scm | 73 +++++++++++++++++++++++++++++------------------- qklib/infix/rule-set.scm | 62 +++++++++++++++++++++++++++------------- 2 files changed, 87 insertions(+), 48 deletions(-) diff --git a/qklib/infix.scm b/qklib/infix.scm index 06aab6b..cdbc055 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -25,11 +25,12 @@ (define (make-default-operator-rule-set) (rule-set (list - (operator '+ 1 'both (unit 0)) - (operator '- 1 'left (unit 0 #t #t)) - (operator '* 2 'both (unit 1)) - (operator '/ 2 'left (unit 1 #t) (prefix '/)) - (operator '^ 3 'right #f (prefix 'expt #t))))) + (operator '= 0 #f #f (prefix '= #f)) + (operator '+ 1 (direction 'left #t) (unit 0) (prefix '+ #t)) + (operator '- 1 (direction 'left) (unit 0 #t #t)) + (operator '* 2 (direction 'left #t) (unit 1)) + (operator '/ 2 (direction 'left) (unit 1 #t) (prefix '/)) + (operator '^ 3 (direction 'right) #f (prefix 'expt #t))))) (define current-operator-rule-set (make-parameter (make-default-operator-rule-set))) @@ -71,43 +72,50 @@ (not-binary-only? (not (operator-prefix-binary-only? op)))) `(,(operator-prefix-symbol op) ,@(if (operator? left-op) - (if (and not-binary-only? - (operator-left? op) - (eqv? (operator-symbol op) (operator-symbol left-op))) - (cdr (->prefix left left-op)) + (if (eqv? (operator-symbol op) (operator-symbol left-op)) + (if not-binary-only? + (cdr (->prefix left left-op)) + (if (operator-left? op) + (list (->prefix left left-op)) + (fail expr))) (list (->prefix left left-op))) (if (and (pair? left) (null? (cdr left))) (if (and not-binary-only? - (operator-left? op) + (or (operator-left? op) + (operator-associative? op)) (pair? (car left)) (eqv? (operator-symbol op) (car (car left)))) (cdr (car left)) (list (car left))) (fail (->infix left op-sym right)))) ,@(if (operator? right-op) - (if (and not-binary-only? - (operator-right? op) - (eqv? (operator-symbol op) (operator-symbol right-op))) - (cdr (->prefix right right-op)) + (if (eqv? (operator-symbol op) (operator-symbol right-op)) + (if not-binary-only? + (cdr (->prefix right right-op)) + (if (operator-right? op) + (list (->prefix right right-op)) + (fail expr))) (list (->prefix right right-op))) (if (and (pair? right) (null? (cdr right))) (if (and not-binary-only? - (operator-right? op) + (or (operator-left? op) + (operator-associative? op)) (pair? (car right)) (eqv? (operator-symbol op) (car (car right)))) (cdr (car right)) (list (car right))) (fail (->infix left op-sym right))))))) - (if (operator-right? op) - (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr))) - (let-values (((op rest) (car+cdr op+rest))) - (make-prefix lst op rest))) - (let ((rev-expr (reverse! expr))) - (let-values (((rev-lst op+rev-rest) (break! (cute eqv? (operator-symbol op) <>) rev-expr))) - (let-values (((op-sym rev-rest) (car+cdr op+rev-rest))) - (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst))))))))) + (cond ((operator-right? op) + (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr))) + (let-values (((op rest) (car+cdr op+rest))) + (make-prefix lst op rest)))) + (else + (let ((rev-expr (reverse! expr))) + (let-values (((rev-lst op+rev-rest) (break! (cute eqv? (operator-symbol op) <>) rev-expr))) + (let-values (((op-sym rev-rest) (car+cdr op+rev-rest))) + (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst)))))))))) (else expr))) (define prefix->infix @@ -147,7 +155,8 @@ (values `(,op-sym ,r-expr) -inf.0) (values `(,(unit-value (operator-unit op)) ,op-sym - ,@(if (operator-right? op) + ,@(if (or (operator-right? op) + (operator-associative? op)) (wrap-when (< r-p p) r-expr) (wrap-when (<= r-p p) r-expr))) p)) @@ -156,17 +165,18 @@ ((null? (cdr (cdr args))) (let-values (((l-expr l-p) (->infix (car args))) ((r-expr r-p) (->infix (cadr args)))) - (values `(,@(if (operator-left? op) + (values `(,@(if (or (operator-left? op) + (operator-associative? op)) (wrap-when (< l-p p) l-expr) (wrap-when (<= l-p p) l-expr)) ,op-sym - ,@(if (operator-right? op) + ,@(if (or (operator-right? op) + (operator-associative? op)) (wrap-when (< r-p p) r-expr) (wrap-when (<= r-p p) r-expr))) p))) (else - (cond ((and (operator-left? op) - (operator-right? op)) + (cond ((operator-associative? op) (values (cdr (append-map! (lambda (arg) (let-values (((x-expr x-p) (->infix arg))) (cons op-sym (wrap-when (< x-p p) x-expr)))) @@ -191,7 +201,12 @@ (cons op-sym (wrap-when (<= r-p p) r-expr)))) (cdr rev-args)))) p)))) - (else (failure expr)))))))) + (else + (values (cdr (append-map! (lambda (arg) + (let-values (((x-expr x-p) (->infix arg))) + (cons op-sym (wrap-when (<= x-p p) x-expr)))) + args)) + p)))))))) (else (values (map ->infix-fst expr) -inf.0))))))) (define (minimum-precedence expr rs) diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm index 122aa56..80ad5e4 100644 --- a/qklib/infix/rule-set.scm +++ b/qklib/infix/rule-set.scm @@ -25,6 +25,7 @@ operator-precedence operator-left? operator-right? + operator-associative? operator-prefix operator-unit @@ -34,6 +35,11 @@ unit-inv? unit-unary? + direction + direction? + direction-left? + direction-associative? + prefix prefix? prefix-symbol @@ -83,37 +89,55 @@ (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f)) (define-record-type - (make-operator symbol precedence assoc unit prefix) + (make-operator symbol precedence dir unit prefix) operator? (symbol operator-symbol) (precedence operator-precedence) - (assoc operator-assoc) + (dir operator-direction) (unit operator-unit) (prefix operator-prefix)) (define operator (case-lambda - ((symbol precedence assoc) - (operator symbol precedence assoc #f)) - ((symbol precedence assoc unit) - (operator symbol precedence assoc unit #f)) - ((symbol precedence assoc unit prefix) - (unless (or (eq? 'none assoc) - (eq? 'left assoc) - (eq? 'right assoc) - (eq? 'both assoc)) - (error "operator: The 3rd argument must be 'none, 'left, 'right or 'both" assoc)) - (make-operator symbol precedence assoc unit prefix)))) + ((symbol precedence) + (operator symbol precedence #f)) + ((symbol precedence direction) + (operator symbol precedence direction #f)) + ((symbol precedence direction unit) + (operator symbol precedence direction unit #f)) + ((symbol precedence direction unit prefix) + (make-operator symbol precedence direction unit prefix)))) + + (define-record-type + (make-direction left? associative?) + direction? + (left? direction-left?) + (associative? direction-associative?)) + + (define (direction-right? assoc) + (not (direction-left? assoc))) + + (define direction + (case-lambda + ((dir) + (direction dir #f)) + ((dir associative?) + (unless (or (eq? 'left dir) + (eq? 'right dir)) + (error "direction: The 1st argument must be 'left or 'right" dir)) + (make-direction (eq? 'left dir) associative?)))) (define (operator-left? x) - (let ((a (operator-assoc x))) - (or (eq? a 'left) - (eq? a 'both)))) + (cond ((operator-direction x) => direction-left?) + (else #f))) (define (operator-right? x) - (let ((a (operator-assoc x))) - (or (eq? a 'right) - (eq? a 'both)))) + (cond ((operator-direction x) => (lambda (a) (not (direction-left? a)))) + (else #f))) + + (define (operator-associative? x) + (cond ((operator-direction x) => direction-associative?) + (else #f))) (define (operator-prefix-symbol op) (cond ((operator-prefix op) => prefix-symbol) -- cgit v1.2.3