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 ++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 44 insertions(+), 29 deletions(-) (limited to 'qklib/infix.scm') 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) -- cgit v1.2.3