From 16ebde37668f976a8e24e8b28b172965b670c592 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Tue, 3 Sep 2024 03:30:21 +0900 Subject: Use rule-set library and modify interface to `(qklib infix)` --- qklib/infix.scm | 191 +++++++++++++++++++++++++++----------------------------- 1 file changed, 92 insertions(+), 99 deletions(-) diff --git a/qklib/infix.scm b/qklib/infix.scm index 91770aa..3cde341 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -15,72 +15,43 @@ (define-library (qklib infix) (export infix->prefix prefix->infix - infix - current-infix-rules) + current-operator-rule-set) (import (scheme base) (scheme case-lambda) - (ice-9 pretty-print) (only (srfi 1) car+cdr fold break! reverse! append-map) - (only (srfi 26) cut) - (only (srfi 128) make-default-comparator) - (only (srfi 146) mapping? mapping-unfold mapping-adjoin mapping-ref/default)) + (only (srfi 26) cut cute) + (srfi 35) + (qklib infix rule-set)) (begin - (define-record-type - (%make-operator symbol precedence left? unit inv?) - operator? - (symbol operator-symbol) - (precedence operator-precedence) - (left? operator-left?) - (unit operator-unit) - (inv? operator-inv?)) - - (define-record-type - (make-unit value) - unit? - (value unit-value)) - - (define infix + (define (make-default-operator-rule-set) + (rule-set + (list + (operator '+ 1 'left (unit 0)) + (operator '- 1 'left (unit 0 #t)) + (operator '* 2 'left (unit 1)) + (operator '/ 2 'left (unit 1 #t)) + (operator '^ 3 'right #f (prefix 'expt))))) + + (define current-operator-rule-set + (make-parameter (make-default-operator-rule-set))) + + (define-condition-type &infix-error &error + infix-error? + (expr infix-error-expr)) + + (define (all-list-copy x) + (map-all-list list-copy x)) + + (define infix->prefix (case-lambda - ((sym) - (infix sym 0)) - ((sym precedence) - (infix sym precedence 'right)) - ((sym precedence left-or-right) - (%make-operator sym precedence (eq? 'left left-or-right) #f #f)) - ((sym precedence left-or-right unit) - (infix sym precedence left-or-right unit #f)) - ((sym precedence left-or-right unit inv?) - (unless (or (eq? 'left left-or-right) - (eq? 'right left-or-right)) - (error "infix: The 3rd argument must be 'left or 'right" left-or-right)) - (%make-operator sym precedence (eq? 'left left-or-right) (make-unit unit) inv?)))) - - (define (infix-rule-list->infix-rule-mapping ops) - (mapping-unfold null? - (lambda (ops) - (values (operator-symbol (car ops)) - (car ops))) - cdr - ops - (make-default-comparator))) - - (define (make-default-infix-rules) - (list (infix '+ 1 'left 0) - (infix '- 1 'left 0 #t) - (infix '* 2 'left 1) - (infix '/ 2 'left 1 #t))) - - (define current-infix-rules - (make-parameter (make-default-infix-rules) - (lambda (x) - (if (mapping? x) - x - (infix-rule-list->infix-rule-mapping x))))) - - (define (infix->prefix expr) - (let ((infix-rules (current-infix-rules))) - (map-all-list (cut infix->prefix-1 <> infix-rules) - expr))) + ((expr failure) + (call/cc + (lambda (return) + (let ((rs (current-operator-rule-set))) + (map-all-list (cut infix->prefix-1 <> rs (lambda (e) (return (failure e)))) + expr))))) + ((expr) + (infix->prefix expr (lambda (e) #f))))) (define (map-all-list f expr) (f (map-cars f expr))) @@ -94,29 +65,56 @@ (map-cars f (cdr expr)))) expr)) - (define (infix->prefix-1 expr ops) - (if (not (pair? expr)) - expr - (let ->prefix ((expr (cons (car expr) (replace-operators (cdr expr) ops)))) ;; all new conses - (define op (minimum-precedence (cdr expr))) - (cond ((operator? op) - (if (operator-left? op) - (let ((rev-expr (reverse! expr))) - (let-values (((rev-lst op+rev-rest) (break! (cut operator=? op <>) rev-expr))) - (let-values (((op rev-rest) (car+cdr op+rev-rest))) - (list (operator-symbol op) (->prefix (reverse! rev-rest)) (->prefix (reverse! rev-lst)))))) - (let-values (((lst op+rest) (break! (cut operator=? op <>) expr))) - (let-values (((op rest) (car+cdr op+rest))) - (list (operator-symbol op) (->prefix lst) (->prefix rest)))))) - ((single? expr) (car expr)) - (else 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) + (let ((left-op (minimum-precedence left rs)) + (right-op (minimum-precedence right rs))) + (cond ((and (operator? left-op) (operator? right-op)) + (list op + (->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))))) + ((operator? right-op) + (if (single? left) + `(,op ,(car left) ,(->prefix right right-op)) + (not-single-error (append left (cons op 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)))))))) + (else expr))) (define (prefix->infix expr) - (let ((infix-rules (current-infix-rules))) - (let-values (((result _precedence) (%prefix->infix expr infix-rules))) + (let ((rs (current-operator-rule-set))) + (let-values (((result _precedence) (%prefix->infix expr rs))) result))) - (define (%prefix->infix expr ops) + (define (operator-inv? x) + (cond ((operator-unit x) => (cut unit-inv? <>)) + (else #f))) + + (define (%prefix->infix expr rs) (let ->infix ((expr expr)) (define (->infix-fst expr) (let-values (((x _) (->infix expr))) @@ -124,7 +122,7 @@ (if (not (pair? expr)) (values expr -inf.0) (let-values (((op args) (car+cdr expr))) - (cond ((mapping-ref/default ops op #f) + (cond ((rule-set-prefix-ref rs op) => (lambda (op) (let ((p (operator-precedence op)) (sym (operator-symbol op))) @@ -156,22 +154,17 @@ (and (pair? x) (null? (cdr x)))) - (define (replace-operators expr ops) - (map (lambda (x) - (mapping-ref/default ops x x)) - expr)) - - (define (expr-precedence expr) - (if (operator? expr) - (operator-precedence expr) - +inf.0)) - - (define (minimum-precedence expr) - (fold (lambda (x y) (if (< (expr-precedence x) (expr-precedence y)) x y)) #f expr)) - - (define (operator=? x y) - (and (operator? x) - (operator? y) - (eq? (operator-symbol x) - (operator-symbol y)))) + (define (minimum-precedence expr rs) + (let ((dummy (operator 'dummy +inf.0))) + (let ((result + (fold (lambda (x y-op) + (let ((x-op (rule-set-infix-ref rs x))) + (cond ((operator? x-op) + (if (<= (operator-precedence x-op) (operator-precedence y-op)) x-op y-op)) + (else y-op)))) + dummy + expr))) + (if (eq? dummy result) + #f + result)))) )) -- cgit v1.2.3