diff options
Diffstat (limited to 'infix-to-scheme')
| -rw-r--r-- | infix-to-scheme/rule-set.scm | 184 |
1 files changed, 0 insertions, 184 deletions
diff --git a/infix-to-scheme/rule-set.scm b/infix-to-scheme/rule-set.scm deleted file mode 100644 index 22ffcc3..0000000 --- a/infix-to-scheme/rule-set.scm +++ /dev/null @@ -1,184 +0,0 @@ -;;; Infix-to-Scheme --- Library for converting infix formula to Scheme expression -;;; Copyright © 2024 Masaya Tojo <masaya@tojo.tokyo> -;;; -;;; This file is part of Infix-to-Scheme. -;;; -;;; Infix-to-Scheme is free software: you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; Infix-to-Scheme is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with Infix-to-Scheme. If not, see -;;; <https://www.gnu.org/licenses/>. - -(define-library (infix-to-scheme rule-set) - (export rule-set - rule-set? - rule-set-infix-ref - rule-set-scheme-ref - - operator - operator? - operator-symbol - operator-scheme-symbol - operator-precedence - operator-left? - operator-right? - operator-associative? - operator-scheme - operator-identity - - identity - identity? - identity-value - identity-inv? - identity-unary? - identity-unary-precedence - - direction - direction? - direction-left? - direction-associative? - - scheme - scheme? - scheme-symbol - scheme-binary-only?) - (import (scheme base) - (scheme case-lambda) - (only (srfi 128) make-eqv-comparator)) - (cond-expand - ((library (srfi srfi-146 hash)) ;; for guile-srfi-146 - (import (only (srfi srfi-146 hash) hashmap-ref/default hashmap-unfold))) - ((library (srfi 146 hash)) - (import (only (srfi 146 hash) hashmap-ref/default hashmap-unfold)))) - (begin - (define-record-type <rule-set> - (make-rule-set operator-hashmap scheme-hashmap) - rule-set? - (operator-hashmap rule-set-operator-hashmap) - (scheme-hashmap rule-set-scheme-hashmap)) - - (define (rule-set operator-list) - (make-rule-set (list->operator-hashmap operator-list) - (list->scheme-hashmap operator-list))) - - (define (list->operator-hashmap ops) - (hashmap-unfold null? - (lambda (ops) - (values (operator-symbol (car ops)) - (car ops))) - cdr - ops - (make-eqv-comparator))) - - (define (list->scheme-hashmap ops) - (hashmap-unfold null? - (lambda (ops) - (let ((op (car ops))) - (values (operator-scheme-symbol op) - (car ops)))) - cdr - ops - (make-eqv-comparator))) - - (define (rule-set-infix-ref rule-set key) - (hashmap-ref/default (rule-set-operator-hashmap rule-set) key #f)) - - (define (rule-set-scheme-ref rule-set key) - (hashmap-ref/default (rule-set-scheme-hashmap rule-set) key #f)) - - (define-record-type <operator> - (make-operator symbol precedence dir identity scheme) - operator? - (symbol operator-symbol) - (precedence operator-precedence) - (dir operator-direction) - (identity operator-identity) - (scheme operator-scheme)) - - (define operator - (case-lambda - ((symbol precedence) - (operator symbol precedence #f)) - ((symbol precedence direction) - (operator symbol precedence direction #f)) - ((symbol precedence direction identity) - (operator symbol precedence direction identity #f)) - ((symbol precedence direction identity scheme) - (when (and identity (identity-unary? identity) - (not (and direction (direction-left? direction)))) - (error "operator: unary operator must be left direction" symbol)) - (make-operator symbol precedence direction identity scheme)))) - - (define-record-type <direction> - (make-direction left? associative?) - direction? - (left? direction-left?) - (associative? direction-associative?)) - - (define (direction-right? assoc) - (not (direction-left? assoc))) - - (define direction - (case-lambda - ((dir) - (direction dir #f)) - ((dir associative?) - (unless (or (eq? 'left dir) - (eq? 'right dir)) - (error "direction: The 1st argument must be 'left or 'right" dir)) - (make-direction (eq? 'left dir) associative?)))) - - (define (operator-left? x) - (cond ((operator-direction x) => direction-left?) - (else #f))) - - (define (operator-right? x) - (cond ((operator-direction x) => (lambda (a) (not (direction-left? a)))) - (else #f))) - - (define (operator-associative? x) - (cond ((operator-direction x) => direction-associative?) - (else #f))) - - (define (operator-scheme-symbol op) - (cond ((operator-scheme op) => (lambda (p) - (and (scheme-has-symbol? p) - (scheme-symbol p)))) - (else (operator-symbol op)))) - - (define-record-type <scheme> - (make-scheme binary-only? has-symbol? symbol) - scheme? - (binary-only? scheme-binary-only?) - (has-symbol? scheme-has-symbol?) - (symbol scheme-symbol)) - - (define scheme - (case-lambda - ((binary-only?) - (make-scheme binary-only? #f #f)) - ((binary-only? symbol) - (make-scheme binary-only? #t symbol)))) - - (define-record-type <identity> - (make-identity value inv? unary? unary-precedence) - identity? - (value identity-value) - (inv? identity-inv?) - (unary? identity-unary?) - (unary-precedence identity-unary-precedence)) - - (define identity - (case-lambda - ((value) (identity value #f)) - ((value inv?) (identity value inv? #f)) - ((value inv? unary?) (identity value inv? unary? #f)) - ((value inv? unary? unary-precedence) (make-identity value inv? unary? unary-precedence)))))) |