diff options
Diffstat (limited to 'qklib/infix/rule-set.scm')
| -rw-r--r-- | qklib/infix/rule-set.scm | 179 |
1 files changed, 0 insertions, 179 deletions
diff --git a/qklib/infix/rule-set.scm b/qklib/infix/rule-set.scm deleted file mode 100644 index db0c4e5..0000000 --- a/qklib/infix/rule-set.scm +++ /dev/null @@ -1,179 +0,0 @@ -;;; Copyright 2024 Masaya Tojo <masaya@tojo.tokyo> -;;; -;;; Licensed under the Apache License, Version 2.0 (the "License"); -;;; you may not use this file except in compliance with the License. -;;; You may obtain a copy of the License at -;;; -;;; http://www.apache.org/licenses/LICENSE-2.0 -;;; -;;; Unless required by applicable law or agreed to in writing, software -;;; distributed under the License is distributed on an "AS IS" BASIS, -;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -;;; See the License for the specific language governing permissions and -;;; limitations under the License. - -(define-library (qklib infix rule-set) - (export rule-set - rule-set? - rule-set-infix-ref - rule-set-prefix-ref - - operator - operator? - operator-symbol - operator-prefix-symbol - operator-precedence - operator-left? - operator-right? - operator-associative? - operator-prefix - operator-identity - - identity - identity? - identity-value - identity-inv? - identity-unary? - identity-unary-precedence - - direction - direction? - direction-left? - direction-associative? - - prefix - prefix? - prefix-symbol - prefix-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 prefix-hashmap) - rule-set? - (operator-hashmap rule-set-operator-hashmap) - (prefix-hashmap rule-set-prefix-hashmap)) - - (define (rule-set operator-list) - (make-rule-set (list->operator-hashmap operator-list) - (list->prefix-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->prefix-hashmap ops) - (hashmap-unfold null? - (lambda (ops) - (let ((op (car ops))) - (values (operator-prefix-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-prefix-ref rule-set key) - (hashmap-ref/default (rule-set-prefix-hashmap rule-set) key #f)) - - (define-record-type <operator> - (make-operator symbol precedence dir identity prefix) - operator? - (symbol operator-symbol) - (precedence operator-precedence) - (dir operator-direction) - (identity operator-identity) - (prefix operator-prefix)) - - (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 prefix) - (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 prefix)))) - - (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-prefix-symbol op) - (cond ((operator-prefix op) => (lambda (p) - (and (prefix-has-symbol? p) - (prefix-symbol p)))) - (else (operator-symbol op)))) - - (define-record-type <prefix> - (make-prefix binary-only? has-symbol? symbol) - prefix? - (binary-only? prefix-binary-only?) - (has-symbol? prefix-has-symbol?) - (symbol prefix-symbol)) - - (define prefix - (case-lambda - ((binary-only?) - (make-prefix binary-only? #f #f)) - ((binary-only? symbol) - (make-prefix 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)))))) |