aboutsummaryrefslogtreecommitdiff
path: root/qklib
diff options
context:
space:
mode:
Diffstat (limited to 'qklib')
-rw-r--r--qklib/infix.scm73
-rw-r--r--qklib/infix/rule-set.scm62
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 <operator>
- (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 <direction>
+ (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)
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-21 23:39:06 +0000