aboutsummaryrefslogtreecommitdiff
path: root/qklib/infix.scm
diff options
context:
space:
mode:
Diffstat (limited to 'qklib/infix.scm')
-rw-r--r--qklib/infix.scm133
1 files changed, 103 insertions, 30 deletions
diff --git a/qklib/infix.scm b/qklib/infix.scm
index 88ebb18..7a897fd 100644
--- a/qklib/infix.scm
+++ b/qklib/infix.scm
@@ -18,7 +18,7 @@
current-operator-rule-set)
(import (scheme base)
(scheme case-lambda)
- (only (srfi 1) car+cdr fold break! reverse! append-map)
+ (only (srfi 1) car+cdr fold fold-right break! reverse! append-map append! append-map!)
(only (srfi 26) cut cute)
(srfi 35)
(qklib infix rule-set))
@@ -26,11 +26,11 @@
(define (make-default-operator-rule-set)
(rule-set
(list
- (operator '+ 1 'left (unit 0 #f #t))
+ (operator '+ 1 'both (unit 0 #f #t))
(operator '- 1 'left (unit 0 #t #t))
- (operator '* 2 'left (unit 1))
- (operator '/ 2 'left (unit 1 #t))
- (operator '^ 3 'right #f (prefix 'expt #t)))))
+ (operator '* 2 'both (unit 1))
+ (operator '/ 2 'left (unit 1 #t) (prefix '/))
+ (operator '^ 3 'right #f (prefix 'expt #f)))))
(define current-operator-rule-set
(make-parameter (make-default-operator-rule-set)))
@@ -66,8 +66,15 @@
(cond ((operator-unit op) => unit-unary?)
(else #f)))
+ (define (operator-prefix-binary-only? op)
+ (cond ((operator-prefix op) => prefix-binary-only?)
+ (else #f)))
+
(define (infix->prefix-1 expr rs fail)
(cond ((and (pair? expr)
+ (single? expr))
+ (car expr))
+ ((and (pair? expr)
(single? (cdr expr))
(let ((op (rule-set-infix-ref rs (car expr))))
(if (and op (operator-unit-unary? op))
@@ -89,31 +96,74 @@
(define (->infix left op-sym right)
(append left (cons op-sym right)))
(let ((left-op (minimum-precedence left rs))
- (right-op (minimum-precedence right rs)))
+ (right-op (minimum-precedence right rs))
+ (not-binary-only? (not (operator-prefix-binary-only? op))))
(cond ((and (operator? left-op) (operator? right-op))
- (list op-sym
- (->prefix left left-op)
- (->prefix right right-op)))
+ `(,(operator-prefix-symbol op)
+ ,@(if (and not-binary-only?
+ (operator-left? op)
+ (eqv? (operator-symbol op) (operator-symbol left-op)))
+ (cdr (->prefix left left-op))
+ (list (->prefix left left-op)))
+ ,@(if (and not-binary-only?
+ (operator-right? op)
+ (eqv? (operator-symbol op) (operator-symbol right-op)))
+ (cdr (->prefix right right-op))
+ (list (->prefix right right-op)))))
((operator? left-op)
(if (single? right)
- (list op-sym (->prefix left left-op) (car right))
+ `(,(operator-prefix-symbol op)
+ ,@(if (and not-binary-only?
+ (operator-left? op)
+ (eqv? (operator-symbol op) (operator-symbol left-op)))
+ (cdr (->prefix left left-op))
+ (list (->prefix left left-op)))
+ ,@(if (and not-binary-only?
+ (operator-right? op)
+ (pair? (car right))
+ (eqv? (operator-symbol op) (car (car right))))
+ (cdr (car right))
+ (list (car right))))
(fail (->infix left op-sym right))))
((operator? right-op)
(if (single? left)
- (list op-sym (car left) (->prefix right right-op))
+ `(,(operator-prefix-symbol op)
+ ,@(if (and not-binary-only?
+ (operator-left? op)
+ (pair? (car left))
+ (eqv? (operator-symbol op) (car (car left))))
+ (cdr (car left))
+ (list (car left)))
+ ,@(if (and not-binary-only?
+ (operator-right? op)
+ (eqv? (operator-symbol op) (operator-symbol right-op)))
+ (cdr (->prefix right right-op))
+ (list (->prefix right right-op))))
(fail (->infix left op-sym right))))
(else
(if (and (single? left) (single? right))
- (list op-sym (car left) (car right))
+ `(,(operator-prefix-symbol op)
+ ,@(if (and not-binary-only?
+ (operator-left? op)
+ (pair? (car left))
+ (eqv? (operator-symbol op) (car (car left))))
+ (cdr (car left))
+ (list (car left)))
+ ,@(if (and not-binary-only?
+ (operator-right? 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-left? op)
+ (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)))))
- (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)))))))
+ (make-prefix (reverse! rev-rest) op-sym (reverse! rev-lst)))))))))
(else expr)))
(define prefix->infix
@@ -143,8 +193,14 @@
=> (lambda (op)
(let ((p (operator-precedence op))
(op-sym (operator-symbol op)))
- (define (select x xp)
- (if (< p xp) x (list x)))
+ (define (left-select op x xp)
+ (if (operator-left? op)
+ (if (<= p xp) x (list x))
+ (if (< p xp) x (list x))))
+ (define (right-select op x xp)
+ (if (operator-right? op)
+ (if (<= p xp) x (list x))
+ (if (< p xp) x (list x))))
(cond ((null? args)
(cond ((and (not (operator-unit-inv? op))
(operator-unit op))
@@ -159,23 +215,40 @@
(values `(,op-sym ,x) -inf.0)
(values `(,(unit-value (operator-unit op))
,op-sym
- ,@(select x xp))
+ ,@(right-select op x xp))
p))
(values x xp))))
(else (failure expr)))))
((null? (cdr (cdr args)))
(let-values (((x xp) (->infix (car args)))
((y yp) (->infix (cadr args))))
- (values `(,@(select x xp) ,op-sym ,@(select y yp)) p)))
+ (values `(,@(left-select op x xp) ,op-sym ,@(right-select op y yp)) p)))
(else
- (if (and (operator-prefix op)
- (prefix-fix? (operator-prefix op)))
- (failure expr)
- (values (cdr (append-map (lambda (arg)
- (let-values (((x xp) (->infix arg)))
- (cons op-sym (select x xp))))
- args))
- p)))))))
+ (cond ((and (operator-left? op)
+ (operator-right? op))
+ (values (cdr (append-map (lambda (arg)
+ (let-values (((x xp) (->infix arg)))
+ (cons op-sym (if (<= p xp) x (list x)))))
+ args))
+ p))
+ ((operator-left? op)
+ (let-values (((x xp) (->infix (car args))))
+ (values (append (if (<= p xp) x (list x))
+ (append-map (lambda (arg)
+ (let-values (((x xp) (->infix arg)))
+ (cons op-sym (if (< p xp) x (list x)))))
+ (cdr args)))
+ p)))
+ (else
+ (let ((rev-args (reverse args)))
+ (let-values (((x xp) (->infix (car rev-args))))
+ (values (reverse
+ (append (if (<= p xp) (reverse x) (list x))
+ (append-map (lambda (arg)
+ (let-values (((x xp) (->infix arg)))
+ (cons op-sym (if (< p xp) x (list x)))))
+ (cdr rev-args))))
+ p))))))))))
(else (values (map ->infix-fst expr) -inf.0)))))))
(define (single? x)
@@ -183,7 +256,7 @@
(null? (cdr x))))
(define (minimum-precedence expr rs)
- (let ((dummy (operator 'dummy +inf.0)))
+ (let ((dummy (operator 'dummy +inf.0 'both)))
(let ((result
(fold (lambda (x y-op)
(cond ((rule-set-infix-ref rs x)
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-21 23:08:40 +0000