├── README.md ├── LICENSE └── match.scm /README.md: -------------------------------------------------------------------------------- 1 | # chez-match 2 | A pattern match macro for chez-scheme 3 | 4 | 5 | To use it just add the folder to chez scheme lib dirs: 6 | 7 | CHEZSCHEMELIBDIRS=~/Code/chez-match scheme 8 | 9 | and `(import (match))`. 10 | 11 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2016, rain-1 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | * Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /match.scm: -------------------------------------------------------------------------------- 1 | (library (match-expanders) 2 | (export push! push-box! pattern-expanders syntax-car syntax-cdr 3 | length=? length>=? append* 4 | join-syntax-symbols) 5 | (import (chezscheme)) 6 | 7 | (define (push-box! b v) 8 | (set-box! b (cons v (unbox b)))) 9 | 10 | (define-syntax push! 11 | (syntax-rules () 12 | ((push! place val) (set! place (cons val place))))) 13 | 14 | (define pattern-expanders (box '())) 15 | 16 | (define syntax-car 17 | (lambda (ls) 18 | (syntax-case ls () 19 | ((x . y) #'x)))) 20 | 21 | (define syntax-cdr 22 | (lambda (ls) 23 | (syntax-case ls () 24 | ((x . y) #'y)))) 25 | 26 | (define (length=? l n) 27 | ;; tests if a list has a certain length 28 | ;; failing early if possible 29 | ;; failing on non-lists 30 | (let loop ((l l) (n n)) 31 | (cond ((< n 0) #f) 32 | ((null? l) (= n 0)) 33 | ((pair? l) (loop (cdr l) (- n 1))) 34 | (else #f)))) 35 | 36 | (define (length>=? l n) 37 | (let loop ((l l) (n n)) 38 | (cond ((<= n 0) #t) 39 | ((null? l) #f) 40 | ((pair? l) (loop (cdr l) (- n 1))) 41 | (else #f)))) 42 | 43 | (define (append* n l t) 44 | (if (= n 0) 45 | (cons l t) 46 | (cons (car l) (append* (- n 1) (cdr l) t)))) 47 | 48 | (define (join-syntax-symbols s1 . rest) 49 | (datum->syntax s1 (string->symbol (apply string-append 50 | (symbol->string (syntax->datum s1)) 51 | (map (lambda (s) 52 | (symbol->string (syntax->datum s))) 53 | rest))))) 54 | 55 | ) 56 | 57 | (library (match-core) 58 | (export match match-pats) 59 | (import (chezscheme) (match-expanders)) 60 | 61 | (define-syntax match 62 | (syntax-rules (else) 63 | ((match ( ...) ...) 64 | (let* ((t ) (stack (list t))) 65 | (match-aux t stack ( (begin ...)) ...))) 66 | ((match ( ...) ... (else ...)) 67 | (match ( ...) ... (_ ...))))) 68 | 69 | (define-syntax match-aux 70 | (syntax-rules () 71 | ((match-aux t stack) 72 | (error 'match "failed to match" t)) 73 | ((match-aux t stack ( ) ( ) ...) 74 | (let ((fk (lambda () (match-aux t stack ( ) ...)))) 75 | (match-pats () stack fk))))) 76 | 77 | (define-syntax match-pats 78 | (lambda (stx) 79 | (syntax-case stx () 80 | ((match-pats () stack sk fk) 81 | #'(if (null? stack) sk (fk))) 82 | ((match-pats (p . ps) stack sk fk) 83 | (let ((pat^ (syntax->datum #'p))) 84 | (cond ((symbol? pat^) 85 | #`(if (null? stack) 86 | (fk) 87 | (let ((p (car stack)) (stack (cdr stack))) 88 | (match-pats ps stack sk fk)))) 89 | ((or (null? pat^) (number? pat^) 90 | (boolean? pat^) (char? pat^)) 91 | #`(match-pats ('p . ps) stack sk fk)) 92 | (else (let ((expander (assoc (car pat^) (unbox pattern-expanders)))) 93 | (unless expander 94 | (error 'match-pats "no expander for pattern" ;(map car (unbox pattern-expanders)) 95 | pat^)) 96 | ((cdr expander) (syntax->list #'p) #'ps #'stack #'sk #'fk))))))))) 97 | 98 | ) 99 | 100 | (library (match) 101 | (export match pattern-expanders foo define-record-matcher) 102 | (import (rename (chezscheme) (define-record %define-record)) 103 | (match-expanders) (match-core)) 104 | 105 | (define-syntax make-record-matcher 106 | (syntax-rules () 107 | ((make-record-matcher rec rec? num-fields (get ...)) 108 | (push-box! pattern-expanders 109 | (cons 'rec 110 | (lambda (p ps stack sk fk) 111 | (let ((pps (cdr p))) 112 | (unless (= num-fields (length pps)) 113 | (error 'make-record-matcher "bad record pattern" (syntax->datum p))) 114 | #`(if (null? #,stack) 115 | (error 'quote-matcher "failure during record match") 116 | (let ((top (car #,stack)) (stack (cdr #,stack))) 117 | (if (rec? top) 118 | (let ((stack (list* (get top) ... stack))) 119 | (match-pats #,(append pps ps) 120 | stack #,sk #,fk)) 121 | (#,fk))))))))))) 122 | 123 | (define-syntax define-record-matcher 124 | (lambda (stx) 125 | (syntax-case stx () 126 | ((define-record-matcher rec (field ...)) 127 | (let* ((getters (map (lambda (f) 128 | (join-syntax-symbols #'rec #'- f)) 129 | (syntax->list #'(field ...)))) 130 | (rec? (join-syntax-symbols #'rec #'?))) 131 | #`(make-record-matcher rec #,rec? #,(length getters) #,getters)))))) 132 | 133 | ;; > (import (match)) 134 | ;; > (define-record kons (kar kdr)) 135 | ;; > (define-record-matcher kons (kar kdr)) 136 | ;; > (match (make-kons 1 2) ((kons x y) (list y x))) 137 | ;; (2 1) 138 | 139 | (define-syntax define-record 140 | (syntax-rules () 141 | ((define-record ( ...)) 142 | (begin (%define-record ( ...)) 143 | (define-record-matcher ( ...)) 144 | (record-reader ' (type-descriptor )))))) 145 | 146 | (define (foo) #t) 147 | 148 | (push-box! pattern-expanders 149 | (cons 'quote 150 | (lambda (p ps stack sk fk) 151 | #`(if (null? #,stack) 152 | (error 'quote-matcher "failure during match") 153 | (let ((top (car #,stack)) (stack (cdr #,stack))) 154 | (if (equal? '#,(cadr p) top) 155 | (match-pats #,ps 156 | stack #,sk #,fk) 157 | (#,fk))))))) 158 | 159 | (push-box! pattern-expanders 160 | (cons 'cons 161 | (lambda (p ps stack sk fk) 162 | (let ((p-1 (cadr p)) 163 | (p-2 (caddr p))) 164 | #`(if (null? #,stack) 165 | (error 'quote-matcher "failure during match") 166 | (let ((top (car #,stack)) (stack (cdr #,stack))) 167 | (if (pair? top) 168 | (let ((stack (list* (car top) (cdr top) stack))) 169 | (match-pats #,(list* p-1 p-2 ps) 170 | stack #,sk #,fk)) 171 | (#,fk)))))))) 172 | 173 | (push-box! pattern-expanders 174 | (cons 'list 175 | (lambda (p ps stack sk fk) 176 | (let ((pps (cdr p))) 177 | #`(if (null? #,stack) 178 | (error 'quote-matcher "failure during match") 179 | (let ((top (car #,stack)) (stack (cdr #,stack))) 180 | (if (length=? top #,(length pps)) 181 | (let ((stack (append top stack))) 182 | (match-pats #,(append pps ps) 183 | stack #,sk #,fk)) 184 | (#,fk)))))))) 185 | 186 | ;; (append* 2 '(a b c d e f) '(foo)) 187 | ;; => (a b (c d e f) (foo)) 188 | 189 | (push-box! pattern-expanders 190 | (cons 'list* 191 | (lambda (p ps stack sk fk) 192 | (let ((pps (cdr p))) 193 | #`(if (null? #,stack) 194 | (error 'quote-matcher "failure during match") 195 | (let ((top (car #,stack)) (stack (cdr #,stack))) 196 | (if (length>=? top #,(- (length pps) 1)) 197 | (let ((stack (append* #,(- (length pps) 1) top stack))) 198 | (match-pats #,(append pps ps) 199 | stack #,sk #,fk)) 200 | (#,fk)))))))) 201 | 202 | (push-box! pattern-expanders 203 | (cons 'quasiquote 204 | (lambda (p ps stack sk fk) 205 | (let* ((q (cadr p)) (q^ (syntax->datum q))) 206 | (cond ((or (null? q^) 207 | (symbol? q^) (number? q^) 208 | (boolean? q^) (char? q^)) 209 | #`(match-pats ('#,q . #,ps) 210 | #,stack #,sk #,fk)) 211 | ((eq? 'unquote (car q^)) 212 | (let ((p (syntax-car (syntax-cdr q)))) 213 | #`(match-pats (#,p . #,ps) 214 | #,stack #,sk #,fk))) 215 | (else 216 | (let ((q-1 (syntax-car q)) (q-2 (syntax-cdr q))) 217 | #`(match-pats ((cons (quasiquote #,q-1) (quasiquote #,q-2)) . #,ps) 218 | #,stack #,sk #,fk)))))))) 219 | 220 | ) 221 | --------------------------------------------------------------------------------