diff options
| -rw-r--r-- | qklib/infix.scm | 42 |
1 files changed, 19 insertions, 23 deletions
diff --git a/qklib/infix.scm b/qklib/infix.scm index 6dc68fb..3f9038b 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -30,7 +30,7 @@ (operator '- 1 'left (unit 0 #t)) (operator '* 2 'left (unit 1)) (operator '/ 2 'left (unit 1 #t)) - (operator '^ 3 'right #f (prefix 'expt))))) + (operator '^ 3 'right #f (prefix 'expt #t))))) (define current-operator-rule-set (make-parameter (make-default-operator-rule-set))) @@ -63,43 +63,39 @@ expr)) (define (infix->prefix-1 expr rs fail) - (define (not-single-error x) - (fail (make-compound-condition - (condition (&infix-error (expr x))) - (condition (&message (message "Invalid infix operator usage")))))) (cond ((minimum-precedence expr rs) => (lambda (op) (let ->prefix ((expr (list-copy expr)) (op op)) - (define (make-prefix left op right) + (define (make-prefix left op-sym right) + (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))) (cond ((and (operator? left-op) (operator? right-op)) - (list op + (list op-sym (->prefix left left-op) (->prefix right right-op))) ((operator? left-op) (if (single? right) - `(,op ,(->prefix left left-op) ,(car right)) - (not-single-error (append left (cons op right))))) + (list op-sym (->prefix left left-op) (car right)) + (fail (->infix left op-sym right)))) ((operator? right-op) (if (single? left) - `(,op ,(car left) ,(->prefix right right-op)) - (not-single-error (append left (cons op right))))) + (list op-sym (car left) (->prefix right right-op)) + (fail (->infix left op-sym right)))) (else (if (and (single? left) (single? right)) - `(,op ,(car left) ,(car right)) - (not-single-error (append left (cons op right)))))))) - (cond ((single? expr) (operator-symbol op)) - ((operator-left? op) - (let ((rev-expr (reverse! expr))) - (let-values (((rev-lst op+rev-rest) (break! (cute eqv? (operator-symbol op) <>) rev-expr))) - (let-values (((op rev-rest) (car+cdr op+rev-rest))) - (make-prefix (reverse! rev-rest) op (reverse! rev-lst)))))) - (else - (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)))))))) + (list op-sym (car left) (car right)) + (fail (->infix left op-sym right))))))) + (if (operator-left? op) + (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))))))) (else expr))) (define (prefix->infix expr) |