From 0ae419a6fce825b093c7c26405bd680ab7a0d977 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Thu, 12 Sep 2024 10:07:48 +0900 Subject: Rename from unit to identity and modify prefix interface --- qklib/infix.scm | 40 ++++++++++++++--------------- qklib/infix/rule-set.scm | 67 +++++++++++++++++++++++++----------------------- 2 files changed, 55 insertions(+), 52 deletions(-) diff --git a/qklib/infix.scm b/qklib/infix.scm index cdbc055..2ea093b 100644 --- a/qklib/infix.scm +++ b/qklib/infix.scm @@ -25,12 +25,12 @@ (define (make-default-operator-rule-set) (rule-set (list - (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))))) + (operator '= 0) + (operator '+ 1 (direction 'left #t) (identity 0)) + (operator '- 1 (direction 'left) (identity 0 #t #t)) + (operator '* 2 (direction 'left #t) (identity 1)) + (operator '/ 2 (direction 'left) (identity 1 #t)) + (operator '^ 3 (direction 'right) #f (prefix #t 'expt))))) (define current-operator-rule-set (make-parameter (make-default-operator-rule-set))) @@ -51,12 +51,12 @@ ((and (pair? expr) (null? (cdr (cdr expr))) (rule-set-infix-ref rs (car expr))) => (lambda (op) - (if (operator-unit-unary? op) + (if (operator-identity-unary? op) (let ((arg (car (cdr expr))) - (unit (operator-unit op))) + (identity (operator-identity op))) (if (rule-set-infix-ref rs arg) (fail expr) - (if (unit-inv? unit) + (if (identity-inv? identity) expr arg))) (fail expr)))) @@ -142,18 +142,18 @@ (let ((p (operator-precedence op)) (op-sym (operator-symbol op))) (cond ((null? args) - (cond ((and (not (operator-unit-inv? op)) - (operator-unit op)) - => (lambda (u) (values (unit-value u) -inf.0))) + (cond ((and (not (operator-identity-inv? op)) + (operator-identity op)) + => (lambda (u) (values (identity-value u) -inf.0))) (else (failure expr)))) ((null? (cdr args)) (let-values (((r-expr r-p) (->infix (car args)))) - (cond ((operator-unit op) + (cond ((operator-identity op) => (lambda (u) - (if (unit-inv? u) - (if (unit-unary? u) + (if (identity-inv? u) + (if (identity-unary? u) (values `(,op-sym ,r-expr) -inf.0) - (values `(,(unit-value (operator-unit op)) + (values `(,(identity-value (operator-identity op)) ,op-sym ,@(if (or (operator-right? op) (operator-associative? op)) @@ -224,12 +224,12 @@ #f result)))) - (define (operator-unit-inv? x) - (cond ((operator-unit x) => (cut unit-inv? <>)) + (define (operator-identity-inv? x) + (cond ((operator-identity x) => (cut identity-inv? <>)) (else #f))) - (define (operator-unit-unary? op) - (cond ((operator-unit op) => unit-unary?) + (define (operator-identity-unary? op) + (cond ((operator-identity op) => identity-unary?) (else #f))) (define (operator-prefix-binary-only? op) diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm index 80ad5e4..96f08cc 100644 --- a/qklib/infix/rule-set.scm +++ b/qklib/infix/rule-set.scm @@ -27,13 +27,13 @@ operator-right? operator-associative? operator-prefix - operator-unit + operator-identity - unit - unit? - unit-value - unit-inv? - unit-unary? + identity + identity? + identity-value + identity-inv? + identity-unary? direction direction? @@ -89,12 +89,12 @@ (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f)) (define-record-type - (make-operator symbol precedence dir unit prefix) + (make-operator symbol precedence dir identity prefix) operator? (symbol operator-symbol) (precedence operator-precedence) (dir operator-direction) - (unit operator-unit) + (identity operator-identity) (prefix operator-prefix)) (define operator @@ -103,10 +103,10 @@ (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)))) + ((symbol precedence direction identity) + (operator symbol precedence direction identity #f)) + ((symbol precedence direction identity prefix) + (make-operator symbol precedence direction identity prefix)))) (define-record-type (make-direction left? associative?) @@ -140,31 +140,34 @@ (else #f))) (define (operator-prefix-symbol op) - (cond ((operator-prefix op) => prefix-symbol) + (cond ((operator-prefix op) => (lambda (p) + (and (prefix-has-symbol? p) + (prefix-symbol p)))) (else (operator-symbol op)))) (define-record-type - (make-prefix symbol binary-only?) + (make-prefix binary-only? has-symbol? symbol) prefix? - (symbol prefix-symbol) - (binary-only? prefix-binary-only?)) + (binary-only? prefix-binary-only?) + (has-symbol? prefix-has-symbol?) + (symbol prefix-symbol)) (define prefix (case-lambda - ((symbol) - (prefix symbol #f)) - ((symbol binary-only?) - (make-prefix symbol binary-only?)))) - - (define-record-type - (make-unit value inv? unary?) - unit? - (value unit-value) - (inv? unit-inv?) - (unary? unit-unary?)) - - (define unit + ((binary-only?) + (make-prefix binary-only? #f #f)) + ((binary-only? symbol) + (make-prefix binary-only? symbol #t)))) + + (define-record-type + (make-identity value inv? unary?) + identity? + (value identity-value) + (inv? identity-inv?) + (unary? identity-unary?)) + + (define identity (case-lambda - ((value) (unit value #f)) - ((value inv?) (unit value inv? #f)) - ((value inv? unary?) (make-unit value inv? unary?)))))) + ((value) (identity value #f)) + ((value inv?) (identity value inv? #f)) + ((value inv? unary?) (make-identity value inv? unary?)))))) -- cgit v1.2.3