aboutsummaryrefslogtreecommitdiff
path: root/infix-to-scheme/rule-set.scm
diff options
context:
space:
mode:
authorMasaya Tojo <masaya@tojo.tokyo>2024-09-19 01:41:21 +0900
committerMasaya Tojo <masaya@tojo.tokyo>2024-09-19 01:41:42 +0900
commitbdcb16aaebafe995b209526ce79e6fc10eb607a4 (patch)
tree5e3205d2af2dda924e49f0ebc0069ab605a12e06 /infix-to-scheme/rule-set.scm
parentef7b603b3bee3e56478a33aa8519e995e869e492 (diff)
Rename from `infix-to-scheme` to `infix-to-prefix`
Diffstat (limited to 'infix-to-scheme/rule-set.scm')
-rw-r--r--infix-to-scheme/rule-set.scm184
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))))))