diff options
| -rw-r--r-- | infix-to-prefix.scm | 94 |
1 files changed, 48 insertions, 46 deletions
diff --git a/infix-to-prefix.scm b/infix-to-prefix.scm index 00e8cc9..3e8b4ca 100644 --- a/infix-to-prefix.scm +++ b/infix-to-prefix.scm @@ -52,17 +52,19 @@ (infix->prefix expr (lambda (e) #f))))) (define (infix->prefix-1 expr rs fail) - (cond ((and (pair? expr) (null? (cdr expr))) (car expr)) - ((minimum-precedence expr rs) - => (lambda (op) - (let ->prefix ((expr (list-copy expr)) - (op op)) - (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)) - (not-binary-only? (not (operator-prefix-binary-only? op)))) + (if (and (pair? expr) (null? (cdr expr))) + (car expr) + (let-values (((op unary?) (minimum-precedence expr rs))) + (if op + (let ->prefix ((expr (list-copy expr)) + (op op) + (unary? unary?)) + (define (make-prefix left op-sym right) + (define (->infix left op-sym right) + (append left (cons op-sym right))) + (let-values (((left-op left-unary?) (minimum-precedence left rs)) + ((right-op right-unary?) (minimum-precedence right rs))) + (let ((not-binary-only? (not (operator-prefix-binary-only? op)))) `(,(operator-prefix-symbol op) ,@(if (operator? left-op) (if (eqv? (operator-symbol op) (operator-symbol left-op)) @@ -70,12 +72,12 @@ (if (and (eqv? op-sym (car left)) (pair? (cdr left)) (null? (cdr (cdr left)))) - (list (->prefix left left-op)) - (cdr (->prefix left left-op))) + (list (->prefix left left-op left-unary?)) + (cdr (->prefix left left-op left-unary?))) (if (operator-left? op) - (list (->prefix left left-op)) + (list (->prefix left left-op left-unary?)) (fail expr))) - (list (->prefix left left-op))) + (list (->prefix left left-op left-unary?))) (if (and (pair? left) (null? (cdr left))) (if (and not-binary-only? @@ -89,11 +91,11 @@ ,@(if (operator? right-op) (if (eqv? (operator-symbol op) (operator-symbol right-op)) (if not-binary-only? - (cdr (->prefix right right-op)) + (cdr (->prefix right right-op right-unary?)) (if (operator-right? op) - (list (->prefix right right-op)) + (list (->prefix right right-op right-unary?)) (fail expr))) - (list (->prefix right right-op))) + (list (->prefix right right-op right-unary?))) (if (and (pair? right) (null? (cdr right))) (if (and not-binary-only? @@ -103,25 +105,24 @@ (eqv? (operator-symbol op) (car (car right)))) (cdr (car right)) (list (car right))) - (fail (->infix left op-sym right))))))) - (cond ((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))) - (if (and (or (null? rev-rest) - (rule-set-infix-ref rs (car rev-rest))) - (and (pair? rev-lst) - (null? (cdr rev-lst)))) - (infix->prefix-1 (append-reverse! rev-rest - (list `(,op-sym ,(car rev-lst)))) - rs - fail) - (make-prefix (reverse! rev-rest) op-sym (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)))))))) - (else expr))) + (fail (->infix left op-sym right)))))))) + + (cond (unary? + (let-values (((lst op+rest) (break! (cute eqv? (operator-symbol op) <>) expr))) + (let-values (((op-sym rest) (car+cdr op+rest))) + (infix->prefix-1 (append lst (list (list op-sym (infix->prefix-1 rest rs fail)))) + rs + fail)))) + ((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)))))) + (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)))))) + expr)))) (define prefix->infix (case-lambda @@ -220,20 +221,21 @@ (let loop ((expr expr) (min #f) (min-precedence +inf.0) + (min-unary? #f) (prev #t)) (if (null? expr) - min + (values min min-unary?) (cond ((rule-set-infix-ref rs (car expr)) => (lambda (current) - (let ((precedence - (if (and (operator-identity-unary? current) - prev) - (operator-identity-unary-precedence current) - (operator-precedence current)))) + (let-values (((precedence current-unary?) + (if (and (operator-identity-unary? current) + prev) + (values (operator-identity-unary-precedence current) #t) + (values (operator-precedence current) #f)))) (if (<= precedence min-precedence) - (loop (cdr expr) current precedence current) - (loop (cdr expr) min min-precedence current))))) - (else (loop (cdr expr) min min-precedence #f)))))) + (loop (cdr expr) current precedence current-unary? current) + (loop (cdr expr) min min-precedence min-unary? current))))) + (else (loop (cdr expr) min min-precedence min-unary? #f)))))) (define (operator-identity-inv? x) (cond ((operator-identity x) => (cut identity-inv? <>)) |