Changeset 39398 in project
- Timestamp:
- 11/27/20 17:52:54 (5 months ago)
- Location:
- release/5/bindings
- Files:
-
- 6 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
release/5/bindings/tags/5.0/bindings.egg
r38814 r39398 1 ((synopsis "Pattern matching with destructuring bindings ")1 ((synopsis "Pattern matching with destructuring bindings and setters") 2 2 (category lang-exts) 3 3 (license "BSD") 4 4 (test-dependencies simple-tests biglists) 5 (dependencies simple-sequences) 5 6 (author "Juergen Lorenz") 6 (version " 4.1")7 (version "5.0") 7 8 (components (extension bindings 8 9 (csc-options "-O3" "-d0")))) -
release/5/bindings/tags/5.0/bindings.scm
r38814 r39398 33 33 #|[ 34 34 Yet another implementation of the bindings egg. 35 It's based on the bind macro, which is a variant of Common Lisp's 36 destructuring bind. 37 38 It not only destructures nested pseudolists but nested sequences as 39 well, which can be vectors, strings, biglists or what have you, provided 40 you have added support for those datatypes. But that's as simple as 41 adding a triple seq? seq-car and seq-cdr to the generic transformer 42 procedure bind-listify*. As this name suggests, every sequence is 43 transformed to an ordinary list at each nesting level. Moreover, this 44 routine handles literals and dotted ends as well. 45 46 The bind macro itself uses bind-list 47 after having processed all literals and the wildcard, an underscore. The 48 rule is, the wildcard matches everything but doesn't bind anything, 49 whereas the literals match only itself, and, of course, don't bind 50 anything. 51 52 All other macros, in particular bind-case, a variant of match in the 53 matchable egg, are based on bind and are implemented as declarative 54 macros. 55 56 One difference to former versions of bind is, that it can be called 57 without a body which results in setting the pattern variables to 58 correspondig values in the nested sequence argument. In other words, 59 this is what was called bind! before. Hence bind! and 60 bind-define are expendable and code duplication is avoided. But for 61 convenience of use, this version is aliased bind! 35 Sequence routines are outsourced to simple-sequences, so that an 36 enhanced version of Paul Graham's dbind (On Lisp, p. 232) can be used, a 37 variant of Common Lisp's destructuring bind. 38 39 But this version of dbind supports setters as well, using dbind without 40 body. The reason to put it all in one huge macro is, that both variants 41 use a common set of subroutines, which are implemented within the macro 42 body. I could have put it into a helper module to be imported by syntax, 43 but this subroutines are without interest outside of dbind. 44 45 Other enhancements include length checks of sequences, a wildcard, _, 46 which matches everything and binds nothing, literals, which match only 47 themselfs but can't of course be bound, and dots, which are extensions of 48 ellipses: two dots accept zero or one items of the same shape as the 49 nested list to its left, and four dots accept only non-empty nested 50 lists. 51 52 Note, that dbind is not exported, but bind and bind! are exported 53 instead. 62 54 ]|# 63 55 64 56 (module bindings ( 65 bind-listify*66 bind-list67 bind-list!68 57 bind 69 58 bind! … … 82 71 bind/cc 83 72 bindings 84 vector-car85 vector-cdr86 vector-null?87 string-car88 string-cdr89 string-null?90 resolve-dots91 73 ) 92 74 93 75 (import scheme 76 (only simple-sequences sequence-db seq-ref seq-ref* seq-tail seq-length) 94 77 (only (chicken condition) condition-case) 95 (only (chicken base) assert cut subvector gensym void receive identityprint case-lambda error)78 (only (chicken base) gensym receive print case-lambda error) 96 79 (only (chicken keyword) keyword?) 97 (only (chicken format) format)80 (only (chicken module) reexport) 98 81 ) 99 82 100 (import-for-syntax (only (chicken keyword) keyword?) 101 (only (chicken format) format)) 102 103 (define vector-car (cut vector-ref <> 0)) 104 (define vector-cdr (cut subvector <> 1)) 105 (define (vector-null? vec) (zero? (vector-length vec))) 106 (define string-car (cut string-ref <> 0)) 107 (define string-cdr (cut substring <> 1)) 108 (define (string-null? str) (zero? (string-length str))) 109 110 (define (literal? x) 111 (or (boolean? x) 112 (string? x) 113 (char? x) 114 (number? x) 115 (keyword? x))) 116 117 (define (dots? xpr) 118 (and (symbol? xpr) 119 (if (memq xpr '(.. ... ....)) #t #f))) 120 121 (define (dotted-list? xpr) 122 (and (list? xpr) 123 (not (null? xpr)) 124 (dots? (car xpr)))) 125 126 ;;; (a b cs ... d e) 127 ;;; -> 128 ;;; (append (a) (b) cs (d) (e)) 129 ;;; to be used in body 130 (define-syntax resolve-dots 131 (ir-macro-transformer 132 (lambda (form inject compare?) 133 (let ((args (cdr form)) 134 (dots? (lambda (sym) 135 (or (compare? sym '..) 136 (compare? sym '...) 137 (compare? sym '....))))) 138 (let ((lists (let loop ((args args) (result '())) 139 (let loop ((args args) (result '())) 140 (cond 141 ((null? args) 142 (reverse result)) 143 ((null? (cdr args)) 144 (if (dots? (car args)) 145 (reverse result) 146 (reverse (cons `(list ,(car args)) result)))) 147 (else 148 (cond 149 ((dots? (cadr args)) 150 (loop (cdr args) 151 (cons (car args) result))) 152 ((dots? (car args)) 153 (loop (cdr args) result)) 154 (else 155 (loop (cdr args) 156 (cons `(list ,(car args)) 157 result))))) 158 ))))) 159 `(append ,@lists)))))) 160 161 ;;; (bind-listify*) 162 ;;; (bind-listify* seq) 163 ;;; (bind-listify* pat seq) 164 ;;; (bind-listify* seq? seq-car seq-cdr) 165 ;;; (bind-listify* seq? seq-car seq-cdr seq-null?) 166 ;;; ---------------------------------------------- 167 ;;; the first version resets the internal database, 168 ;;; the second returns the car-cdr-null? list corresponding to seq, 169 ;;; the third does the actual work transforming seq to a nested list 170 ;;; and the last two add support for a new sequence type. 171 (define bind-listify* 172 (let ((db (list (cons (lambda (x) #t) 173 (list car cdr null?))))) 174 (case-lambda 175 (() (set! db ; reset 176 (list (cons (lambda (x) #t) 177 (list car cdr null?))))) 178 ((seq) 179 (let loop ((db db)) 180 (if ((caar db) seq) 181 (cdar db) 182 (loop (cdr db))))) 183 ((pat seq) 184 (let ((gstop (gensym 'stop)) 185 (seq-car (car (bind-listify* seq))) 186 (accessors (bind-listify* seq))) 187 (let ((seq-cdr (cadr accessors)) 188 (seq-null? 189 (if (null? (cddr accessors)) 190 (lambda (seq) 191 (eq? (condition-case (seq-car seq) 192 ((exn) gstop)) 193 gstop)) 194 (caddr accessors)))) 195 (let loop ((pat pat) (seq seq) (result '())) 196 (cond 197 ((null? pat) 198 (if (seq-null? seq) 199 (reverse result) 200 (error 'bind-listify* "length mismatch" pat seq))) 201 ((and (pair? pat) (dotted-list? (cdr pat))) ; new 202 (let ((pfirst (car pat)) 203 (len (- (let iloop ((seq seq) (result 0)) 204 (if (seq-null? seq) 205 result 206 (iloop (seq-cdr seq) (+ result 1)))) 207 (length (cddr pat))))) 208 (receive (head tail) 209 (let iloop ((tail seq) (k 0) (head '())) 210 (cond 211 ((seq-null? tail) 212 (values (reverse head) tail)) 213 ((= k len) 214 (values (reverse head) tail)) 215 (else 216 (iloop (seq-cdr tail) 217 (+ k 1) 218 (cons (seq-car tail) head))))) 219 ;(print "HHH" head) 220 (case (cadr pat) 221 ((..) 222 (assert (or (null? head) (null? (cdr head))))) 223 ((...) 224 (assert #t)) 225 ((....) 226 (assert (pair? head))) 227 (else 'bind-listify* "can't happen")) 228 (cond 229 ((symbol? pfirst) 230 (if (eq? pfirst '_) 231 (error 'bind-listify* 232 "dots mustn't follow wildcard") 233 (append 234 (reverse result) 235 (cons head 236 (bind-listify* (cddr pat) tail))))) 237 ((literal? pfirst) 238 (error 'bind-listify* 239 "dots mustn't follow literal")) 240 ((pair? pfirst) 241 (assert (all-bindable? pfirst head)) 242 (letrec 243 ((recompose 244 (lambda (pat seq) 245 ;;; (a (b c)) ((1 (10 100)) (2 (20 200))) 246 ;;; -> 247 ;;; (a (b c)) ((1 2) ((10 20) (100 200))) 248 (cond 249 ((null? pat) '()) 250 ((symbol? pat) seq) 251 (else 252 (let ((pf (car pat)) 253 (lf (map car 254 (map (lambda (s) 255 (bind-listify* 256 pat s)) 257 seq))) 258 (pr (cdr pat)) 259 (lr (map cdr 260 (map (lambda (s) 261 (bind-listify* 262 pat s)) 263 seq)))) 264 (if (pair? pf) 265 (cons (recompose pf lf) (recompose pr lr)) 266 (cons lf (recompose pr lr))))))))) 267 (append 268 (reverse result) 269 (cons (recompose pfirst head) 270 (bind-listify* (cddr pat) tail))))) 271 )))) 272 ((pair? pat) 273 (let ((pfirst (car pat)) 274 (prest (cdr pat)) 275 (sfirst (seq-car seq)) 276 (srest (seq-cdr seq))) 277 (cond 278 ((and (symbol? pfirst) (eq? pfirst '_)) 279 (loop prest srest result)) 280 ((symbol? pfirst) 281 (loop prest srest (cons sfirst result))) 282 ((null? pfirst) ;;; 283 (if (seq-null? sfirst) 284 (loop prest 285 srest 286 (cons (bind-listify* pfirst sfirst) result)) 287 (error 'bind-listify* "length mismatch" 288 pfirst sfirst))) 289 ((literal? pfirst) 290 (if (equal? pfirst sfirst) 291 (loop prest srest result) 292 (error 'bind-listify* 293 (format #f "literals ~s and ~s not equal?~%" 294 pfirst sfirst)))) 295 ((pair? pfirst) 296 (loop prest 297 srest 298 (cons (bind-listify* pfirst sfirst) result))) 299 (else (error 'bind-listify* 300 (format #f "~s is not a valid literal~%") 301 pfirst)) 302 ))) 303 (else 304 (cond 305 ((and (symbol? pat) (eq? pat '_)) 306 (reverse result)) 307 ((symbol? pat) 308 (reverse (cons seq result))) 309 ((literal? pat) 310 (if (equal? pat seq) 311 (reverse result) 312 (error 'bind-listify* 313 (format #f "literals ~s and ~s not equal?~%" 314 pat seq)))) 315 (else (error 'bind-listify* 316 (format #f "~s is not a valid literal~%") 317 pat)) 318 ))))))) 319 ((seq? seq-car seq-cdr) 320 (set! db (cons (cons seq? 321 (list seq-car seq-cdr)) db))) 322 ((seq? seq-car seq-cdr seq-null?) 323 (set! db (cons (cons seq? 324 (list seq-car seq-cdr seq-null?)) db))) 325 ))) 326 327 ;;; (bind-list pat lst) 328 ;;; (bind-list pat lst xpr . xprs) 329 ;;; ------------------------------ 330 ;;; nested versions of bind (symbol-lists only) 331 (define-syntax bind-list 332 (ir-macro-transformer 333 (lambda (form inject compare?) 334 (let ((pat (cadr form)) 335 (lst (caddr form)) 336 (body (cdddr form)) 337 ) 338 (let* ( 339 ;; (a (b c) d) -> (a (g b c) d) 340 (pat* (map (lambda (s) 341 (if (symbol? s) 342 s 343 (cons (gensym) s))) 344 pat)) 345 ;; (a (b c) d) -> (a g d) 346 (flat-pat* (map (lambda (s) 347 (if (symbol? s) 348 s 349 (car s))) 350 pat*)) 351 ) 352 ;(print pat " " pat* " " flat-pat*) 353 (receive (pairs syms) ; filter 354 ;; (a (g b c) d) -> ((g b c)) (a d) 355 (let loop ((lst pat*) (yes '()) (no '())) 356 (cond 357 ((null? lst) 358 (values (reverse yes) (reverse no))) 359 ((pair? (car lst)) 360 (loop (cdr lst) (cons (car lst) yes) no)) 361 ((symbol? (car lst)) 362 (loop (cdr lst) yes (cons (car lst) no))) 363 (else (error 'bind-list "can't happen")))) 364 ;(print pairs " PS " syms) 365 (if (null? body) 366 ;; without body, i.e. multiple set! 367 (if (null? pairs) ; flat list 368 `(if (= (length ',syms) (length ,lst)) 369 ,(let loop ((pat syms) (lst lst) (result '(begin))) 370 (if (null? pat) 371 (reverse result) 372 (loop (cdr pat) 373 `(cdr ,lst) 374 (cons `(set! ,(car pat) (car ,lst)) result)))) 375 (error 'bind-list "length mismatch" ',pat ,lst)) 376 ;; (bind-list (a (b c)) '(1 (2 3))) 377 ;; -> 378 ;; (begin (bind-list (a g) lst) 379 ;; (bind-list (b c) g)) 380 `(begin (bind-list ,flat-pat* ,lst) 381 ,@(map (lambda (pair) 382 `(bind-list ,(cdr pair) ,(car pair))) 383 pairs))) 384 ;; with body 385 (if (null? pairs) ; flat list 386 `(apply (lambda ,syms ,@body) 387 ,lst) 388 ;; (bind-list* (a (b c)) '(1 (2 3)) body) 389 ;; -> 390 ;; (apply (lambda (a g) (bind-list* (b c) g body)) 391 ;; lst) 392 `(apply 393 (lambda ,flat-pat* 394 ,(let loop ((pairs pairs)) 395 (if (null? pairs) 396 `(begin ,@body) 397 `(bind-list ,(cdar pairs) 398 ,(caar pairs) 399 ,(loop (cdr pairs)))))) 400 ,lst)) 401 ))))))) 402 403 ;;; (bind-list! pat) 404 ;;; (bind-list! pat lst) 405 ;;; -------------------- 406 ;;; list version of bind! 407 (define-syntax bind-list! 408 (syntax-rules () 409 ((_ pat lst) 410 (bind-list pat lst)) 411 ((_ pat) 412 (bind-list pat 'pat)) 413 )) 414 415 ;;; (bind pat seq) 416 ;;; (bind pat seq . body) 417 ;;; --------------------- 418 ;;; Note, that the destructuring of pat and seq happen at different 419 ;;; times: The former at compile-time, the latter at run-time. 420 ;;; Consequently, some code in bind almost duplicates some code in 421 ;;; bind-listify*. 422 (define-syntax bind 83 (reexport (only simple-sequences sequence-db)) 84 85 (import-for-syntax (only (chicken keyword) keyword?)) 86 87 ;;; Graham's dbind for sequences with length checks, literals, 88 ;;; wildcard and dots, as well as setters. 89 (define-syntax dbind 423 90 (er-macro-transformer 424 91 (lambda (form rename compare?) 425 92 (let ( 426 (pat (cadr form)) 427 (seq (caddr form)) 428 (body (cdddr form)) 93 (%x (rename 'x)) 429 94 (%_ (rename '_)) 430 (%bind-list (rename 'bind-list)) 431 (%bind-listify* (rename 'bind-listify*)) 432 (literal? (lambda (x) 433 (or (boolean? x) 434 (string? x) 435 (char? x) 436 (number? x) 437 (keyword? x)))) 438 (dotted-list? (lambda (x) 439 (and (list? x) 440 (not (null? x)) 441 (if (memq (car x) '(.. ... ....)) 442 #t #f)))) 95 (%.. (rename '..)) 96 (%... (rename '...)) 97 (%.... (rename '....)) 98 (%if (rename 'if)) 99 (%or (rename 'or)) 100 (%map (rename 'map)) 101 (%let (rename 'let)) 102 (%set! (rename 'set!)) 103 (%begin (rename 'begin)) 104 (%error (rename 'error)) 105 (%zero? (rename 'zero?)) 106 (%equal? (rename 'equal?)) 107 (%lambda (rename 'lambda)) 108 (%seq-ref (rename 'seq-ref)) 109 (%seq-ref* (rename 'seq-ref*)) 110 (%seq-tail (rename 'seq-tail)) 111 (%seq-length (rename 'seq-length)) 112 (%positive? (rename 'positive?)) 443 113 ) 444 114 (letrec ( 445 (listify* 115 (literal? 116 (lambda (p) 117 (or (boolean? p) 118 (char? p) 119 (number? p) 120 (string? p) 121 (keyword? p)))) 122 (mappend 123 (lambda (fn lists) 124 (apply append (map fn lists)))) 125 (dots? 126 (lambda (sym) 127 (or (compare? sym %..) 128 (compare? sym %...) 129 (compare? sym %....)))) 130 (check-dots 131 (lambda (sym seq) 132 `(,(gensym) 133 (,%if 134 ,(cond 135 ((compare? sym %..) 136 `(,%or (,%zero? (,%seq-length ,seq)) 137 (,%zero? (,%seq-length (,%seq-tail ,seq 1))))) 138 ((compare? sym %...) #t) 139 ((compare? sym %....) 140 `(,%positive? (,%seq-length ,seq)))) 141 (,%seq-length ,seq) 142 (,%error 'check-dots "wrong size for this dots" ,seq ',sym))))) 143 (indices 144 ;;; (a b) -> ((a . 0) (b . 1)) 145 ;;; (a (b (c))) -> ((a . 0) (b 1 . 0) (c 1 1 . 0)) 446 146 (lambda (pat) 447 (let loop ((pat pat) (result '())) 448 (cond 449 ((null? pat) 450 (reverse result)) 451 ((and (symbol? pat) ;(eq? pat '_)) 452 (compare? pat %_)) 453 (reverse result)) 454 ((symbol? pat) 455 (reverse (cons pat result))) 456 ((literal? pat) 457 (reverse result)) 458 ((and (pair? pat) (dotted-list? (cdr pat))) 459 (let ((first (car pat)) (rest (cdr pat))) 460 (cond 461 ((and (symbol? first) (eq? first '_)) 462 (error 'bind "dots mustn't follow wildcard")) 463 ((symbol? first) 464 (loop (cdr rest) (cons first result))) 465 ((literal? first) 466 (error 'bind "dots mustn't follow literal")) 467 ((pair? first) 468 (loop (cdr rest) (cons (listify* first) result))) 469 ))) 470 ((pair? pat) 471 (let ((first (car pat)) (rest (cdr pat))) 472 (cond 473 ((and (symbol? first) ;(eq? first '_)) 474 (compare? first %_)) 475 (loop rest result)) 476 ((symbol? first) 477 (loop rest (cons first result))) 478 ((null? first) ;;; 479 (loop rest (cons first result))) 480 ((literal? first) 481 (loop rest result)) 482 ((pair? first) 483 (loop rest (cons (listify* first) result))) 484 ))) 485 )))) 147 (receive (flat ind) 148 (let recur ((pat pat) (k 0)) 149 (cond 150 ((null? pat) 151 (values '() '())) 152 ((pair? pat) 153 (let ((p (car pat)) (ps (cdr pat))) 154 (receive (p* i*) (recur p 0) 155 (receive (ps* is*) (recur ps (+ k 1)) 156 (if (pair? p) 157 (values (append p* ps*) 158 (append (map (lambda (x) (cons k x)) i*) 159 is*)) 160 (values (cons p ps*) 161 (cons k is*))))))) 162 (else ;symbol 163 (values '() '())))) 164 (map cons flat ind)))) 165 (map-seq-ref* 166 ;;; '(a (b c)) '((1 (2 3)) (10 (20 30))) 167 ;;; -> 168 ;;; '((a (1 10))) (b (2 30)) (c (3 30))) 169 (lambda (pat seqs) 170 (let recur ((pi (indices pat))) 171 (if (null? pi) 172 '() 173 (let ((api (car pi)) (dpi (cdr pi))) 174 (cons (list (car api) 175 `(,%map (,%lambda (,%x) 176 (,%seq-ref* ,%x ',(cdr api))) 177 ,seqs)) 178 (recur dpi))))))) 179 (destruc 180 ;; (destruc '(a (b . c) . d) 'seq) 181 ;; -> 182 ;; ((a (seq 0)) 183 ;; ((#!g (seq 1)) (b (#!g 0)) (c (#!g 1 #f))) 184 ;; (d (seq 2 #f))) 185 (lambda (pat seq) 186 (let loop ((pat pat) (seq seq) (n 0)) 187 (if (pair? pat) 188 (let ((p (car pat)) 189 (q (cdr pat)) 190 (recu (loop (cdr pat) seq (+ n 1)))) 191 (cond 192 ((symbol? p) 193 (cond 194 ((compare? p %_) ; wildcard 195 recu) 196 ((and (pair? q) (dots? (car q))) ;;;; 197 ;(print p " PQ " q) 198 (let ((seqs `(,%seq-tail ,seq ,n))) 199 ;(cons (list p seqs) '()))) ;ok, ohne checks 200 (cons (list (check-dots (car q) seqs) 201 (list p seqs)) 202 '()))) 203 (else 204 (cons `(,p (,%seq-ref ,seq ,n)) recu)))) 205 ;; literals 206 ((literal? p) 207 (cons `(,(gensym) 208 (,%if (,%equal? (,%seq-ref ,seq ,n) ,p) 209 #t 210 (,%error 'dbind 211 "literals don't match" 212 (,%seq-ref ,seq ,n) ,p))) 213 recu)) 214 ;; pair 215 (else 216 (cond 217 ((and (pair? q) (dots? (car q))) ;;;;; 218 (let ((seqs `(,%seq-tail ,seq ,n))) 219 (cons (cons (check-dots (car q) seqs) 220 (map-seq-ref* p seqs)) 221 '()))) 222 (else 223 (let ((g (gensym))) 224 (cons (cons `(,g (,%seq-ref ,seq ,n)) 225 (loop p g 0)) 226 recu)))))) ) 227 (let ((tail `(,%seq-tail ,seq ,n))) 228 (cond 229 ((null? pat) 230 `((,(gensym) 231 (,%if (,%zero? (,%seq-length ,tail)) 232 #t 233 (,%error 'dbind 234 "tail not empty?" 235 ,tail))))) 236 ((literal? pat) ;;;;;; 237 `((,(gensym) 238 (,%if (,%equal? (,%seq-tail ,seq ,n) ,pat) 239 #t 240 (,%error 'dbind 241 "literals don't match" 242 (,%seq-tail ,seq ,n) ,pat))))) 243 (else `((,pat ,tail))))))))) 244 (dbind-ex 245 ;; -> 246 ;; (let ((a (seq 0)) (#!g (seq 1)) (d (seq 2 #f))) 247 ;; (let ((b (#!g 0)) (c (#!g 1 #f))) 248 ;; (begin body))) 249 (lambda (binds body) 250 (if (null? binds) 251 `(,%begin ,@body) 252 `(,%let ,(map (lambda (b) 253 (if (pair? (car b)) (car b) b)) 254 binds) 255 ,(dbind-ex (mappend (lambda (b) 256 (if (pair? (car b)) 257 (cdr b) 258 '())) 259 binds) 260 body))))) 261 (dbind-set 262 ;; -> 263 ;; (begin 264 ;; (set! a (seq 0)) (set! #!g (seq 1)) (set! d (seq 2 #f)) 265 ;; (set! b (#!g 0)) (set! c (#!g 1 #f))) 266 (lambda (binds) 267 (mappend (lambda (b) 268 (if (pair? (car b)) 269 (cons `(,%set! ,(caar b) ,(cadar b)) 270 (dbind-set (cdr b))) 271 (list `(,%set! ,(car b) ,(cadr b))))) 272 binds))) 486 273 ) 487 (if (null? body) 488 ;; without body 489 `(,%bind-list ,(listify* pat) 490 (,%bind-listify* ',pat ,seq)) 491 ;; with body 492 (let ((xpr (car body)) (xprs (cdr body))) 493 `(,%bind-list ,(listify* pat) 494 (,%bind-listify* ',pat ,seq) 495 ,xpr ,@xprs))) 496 ))))) 274 (let ((pat (cadr form)) 275 (seq (caddr form)) 276 (body (cdddr form)) 277 (gseq (gensym 'seq))) 278 `(,%let ((,gseq ,seq)) 279 ,(if (null? body) 280 ;; setters 281 (cond 282 ((null? pat) 283 `(,%if (,%zero? (,%seq-length ,gseq)) 284 (,%if #f #f) 285 (,%error 'dbind "seq too long" ,gseq ',pat))) 286 ((compare? pat %_) 287 `(,%if #f #f)) 288 ((literal? pat) 289 `(,%if (,%equal? ,pat ,gseq) 290 (,%if #f #f) 291 (,%error 'dbind "literals don't match" 292 ,pat ,gseq))) 293 ((symbol? pat) 294 `(,%set! ,pat ,gseq)) 295 ((pair? pat) 296 `(,%begin ,@(dbind-set (destruc pat gseq))))) 297 ;; binders 298 (cond 299 ((null? pat) 300 `(,%if (,%zero? (,%seq-length ,gseq)) 301 (,%begin ,@body) 302 (,%error 'dbind "seq too long" ,gseq ',pat))) 303 ((compare? pat %_) 304 `(,%begin ,@body)) 305 ((literal? pat) 306 `(,%if (,%equal? ,pat ,gseq) 307 (,%begin ,@body) 308 (,%error 'dbind "literals don't match" 309 ,pat ,gseq))) 310 ((symbol? pat) 311 `(,%let ((,pat ,gseq)) ,@body)) 312 ((pair? pat) 313 (dbind-ex (destruc pat gseq) body))) 314 )))))))) 315 316 ;;; (bind pat seq xpr . xprs) 317 ;;; ------------------------- 318 ;;; binds pattern variables of pat to corresponding places in seq 319 ;;; and executes body xpr . xprs in this context. 320 ;;; Literals, wildcard, length checks and dots are supported. 321 (define-syntax bind 322 (syntax-rules () 323 ((_ pat seq xpr . xprs) 324 (dbind pat seq xpr . xprs)))) 497 325 498 326 ;;; (bind! pat seq) 499 327 ;;; (bind! pat) 500 328 ;;; --------------- 501 ;;; alias to bind without body329 ;;; setters corresponding to bind 502 330 (define-syntax bind! 503 331 (syntax-rules () 504 332 ((_ pat seq) 505 ( bind pat seq))333 (dbind pat seq)) 506 334 ((_ pat) 507 ( bind pat 'pat))))335 (dbind pat 'pat)))) 508 336 509 337 ;;; (bindable? pat (where . fenders) seq) … … 515 343 (syntax-rules (where) 516 344 ((_ pat (where fender ...) seq) 517 (condition-case ( bind pat seq (and fender ...))345 (condition-case (dbind pat seq (and fender ...)) 518 346 ((exn) #f))) 519 347 ((_ pat seq) 520 (condition-case ( bind pat seq #t)348 (condition-case (dbind pat seq #t) 521 349 ((exn) #f))) 522 350 ;; curried versions … … 567 395 ((_ seq (pat (where fender ...) xpr . xprs)) 568 396 (if (bindable? pat (where fender ...) seq) 569 ( bind pat seq xpr . xprs)397 (dbind pat seq xpr . xprs) 570 398 (error 'bind-seq "sequence doesn't match pattern with fenders" 571 399 seq 'pat 'fender ...))) 572 400 ((_ seq (pat xpr . xprs)) 573 401 (if (bindable? pat seq) 574 ( bind pat seq xpr . xprs)402 (dbind pat seq xpr . xprs) 575 403 (error 'bind-seq "sequence doesn't match pattern" seq 'pat))) 576 404 ((_ seq (pat (where fender ...) xpr . xprs) . clauses) 577 405 (if (bindable? pat (where fender ...) seq) 578 ( bind pat seq xpr . xprs)406 (dbind pat seq xpr . xprs) 579 407 (bind-case seq . clauses))) 580 408 ((_ seq (pat xpr . xprs) . clauses) 581 409 (if (bindable? pat seq) 582 ( bind pat seq xpr . xprs)410 (dbind pat seq xpr . xprs) 583 411 (bind-case seq . clauses))) 584 412 )) … … 605 433 (syntax-rules () 606 434 ((_ pat xpr . xprs) 607 (lambda (x) ( bind pat x xpr . xprs)))435 (lambda (x) (dbind pat x xpr . xprs))) 608 436 )) 609 437 … … 614 442 (syntax-rules () 615 443 ((_ pat xpr . xprs) 616 (lambda x ( bind pat x xpr . xprs)))444 (lambda x (dbind pat x xpr . xprs))) 617 445 )) 618 446 … … 685 513 686 514 ;;; (bind-loop pat seq xpr ....) 687 ;;; ---- 515 ;;; ---------------------------- 688 516 ;;; anaphoric version of bind, introducing loop routine behind the scene 689 517 (define-syntax bind-loop … … 745 573 (let () xpr . xprs)) 746 574 ((_ ((pat seq)) xpr . xprs) 747 ( bind pat seq xpr . xprs))575 (dbind pat seq xpr . xprs)) 748 576 ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs) 749 ( bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))577 (dbind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs))) 750 578 )) 751 579 … … 757 585 (syntax-rules () 758 586 ((_ ((pat seq) ...) xpr . xprs) 759 ( bind (pat ...) (list seq ...) xpr . xprs))587 (dbind (pat ...) (list seq ...) xpr . xprs)) 760 588 ((_ name ((pat seq) ...) xpr . xprs) 761 589 ((letrec ((name (bind-lambda* (pat ...) xpr . xprs))) … … 780 608 (syntax-rules () 781 609 ((_ pat seq xpr . xprs) 782 ( bind pat 'pat610 (dbind pat 'pat 783 611 (bind! pat seq) 784 612 xpr . xprs)))) … … 816 644 (define bindings 817 645 (symbol-dispatcher '( 646 (sequence-db 647 procedure: 648 (sequence-db) 649 (sequence-db seq) 650 (sequence-db seq? seq-length seq-ref seq-tail seq-maker . pos?) 651 "sequence database processing, reexported from simple-sequences:" 652 "the first resets the database to the standard with" 653 "lists, pairs, vectors and strings," 654 "the second returns the vector of handlers as well as the discriminator," 655 "the third adds a new database record either at the end or before the" 656 "pos? discriminator." 657 "A record cosists of a discriminator, seq?, and a vector with items" 658 "seq-lenth, seq-ref, seq-tail and seq-maker patterned after vectors." 659 "Note, that the last record can handle atoms, albeit it is not a" 660 "sequence." 661 ) 818 662 (bindings 819 663 procedure: 820 664 (bindings sym ..) 821 665 "documentation procedure") 822 (bind-listify*823 generic procedure:824 (bind-listify*)825 (bind-listify* seq)826 (bind-listify* pat seq)827 (bind-listify* seq? seq-car seq-cdr)828 (bind-listify* seq? seq-car seq-cdr seq-null?)829 "the first resets the internal database for lists only"830 "the second returns the car-cdr-pair corresponding to seq"831 "the third transforms the nested pseudolist seq to a nested list"832 "and the last two add support for a new sequence type to the"833 "internal database, where seq-null? is needed only if"834 "seq-car doesn't raise an exception on an empty sequence")835 (bind-list836 macro:837 (bind-list pat lst)838 (bind-list pat lst . body)839 "list version of bind: destructure nested symbol-lists only")840 (bind-list!841 macro:842 (bind-list! pat lst)843 (bind-list! pat)844 "the former is an alias to bind-list wtihout body"845 "the latter alias to (bind-list! pat 'pat)")846 666 (bind 847 667 macro: … … 918 738 "binds cc to the current contiunation" 919 739 "and execute xpr ... in this context") 920 (resolve-dots921 macro:922 (resolve-dots . args)923 "where args is a list of items which might be followed by dots."924 "The item before dots must be a list, which is spliced into"925 "the resulting list removing the dots")926 (vector-car927 procedure:928 (vector-car vec)929 "vector-analog of car")930 (vector-cdr931 procedure:932 (vector-cdr vec)933 "vector-analog of cdr")934 (vector-null?935 procedure:936 (vector-null? vec)937 "vector-analog of null?")938 (string-car939 procedure:940 (string-car str)941 "string-analog of car")942 (string-cdr943 procedure:944 (string-cdr str)945 "string-analog of cdr")946 (string-null?947 procedure:948 (string-null? str)949 "string-analog of null?")950 740 ))) 951 741 952 742 ) ; module 953 743 954 ;(import bindings simple-tests)955 -
release/5/bindings/tags/5.0/tests/run.scm
r38814 r39398 7 7 (chicken base) 8 8 (chicken condition) 9 biglists 9 10 ) 10 11 11 (define-checks (listify? verbose?)12 (begin ;; reset internal database13 (bind-listify*)14 ;; add support for vectors and strings15 (bind-listify* vector? vector-car vector-cdr)16 (bind-listify* string? string-car string-cdr)17 #t)18 #t19 (bind-listify* "x")20 (list string-car string-cdr)21 (bind-listify* 'a 1)22 '(1)23 (bind-listify* '(a . as) #(1 2 3))24 '(1 #(2 3))25 (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))26 '(1 (2) 3)27 (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))28 '(1 (2 (3 (300)) 4) #(50))29 (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))30 '(1 (30) 5)31 (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))32 '(1 (30) (5))33 (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))34 '(1 (30) (5))35 (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))36 '(1 (#\y) (5))37 (bind-listify* '(x) "x")38 '(#\x)39 (bind-listify* '(x . y) "xyz")40 '(#\x "yz")41 (bind-listify* 'x 1)42 '(1)43 (bind-listify* '(x) #(1))44 '(1)45 (bind-listify* '(x . y) #(1 2 3))46 '(1 #(2 3))47 (bind-listify* '(#f ()) #(#f #()))48 '(())49 (bind-listify* '(as ... b c) '(1 2 3 40 50))50 '((1 2 3) 40 50)51 (bind-listify* '(as ... b c) '(40 50))52 '(() 40 50)53 (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))54 '(-2 -1 (1 2 3) 40 50)55 (bind-listify* '(x y as ... b c) '(-2 -1 40 50))56 '(-2 -1 () 40 50)57 (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))58 '(((1 10) ((2 20) (3 30))) 4 5)59 (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))60 '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)61 (bind-listify* '(x y (as (bs cs)) ... d e) #(-1 0 (1 (2 3)) (10 (20 30)) 4 5))62 '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)63 (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) #(10 (20 30)) 4 5))64 '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)65 (bind-listify* '(x y (as (bs (cs))) ... d e)66 '(-1 0 (1 (2 (3))) #(10 (20 (30))) 4 5))67 '(-1 0 ((1 10) ((2 20) ((3 30)))) 4 5)68 )69 ;(listify?)70 71 (define-checks (lists-only? verbose?)72 (begin ;; reset internal database73 (bind-listify*)74 #t)75 #t76 ;; this would work with string support:77 (condition-case (bind (x) "x" x)78 ((exn) #f))79 #f80 (bind-list (a b) '(1 2) (list a b))81 '(1 2)82 (bind-list (x (y (z))) '(1 (2 (3))) (list x y z))83 '(1 2 3)84 (let ((x #f) (y #f))85 (bind-list (x y) '(1 2))86 (and (= x 1) (= y 2)))87 #t88 (let ((x #f) (y #f))89 (bind-list (x (y)) '(1 (2)))90 (and (= x 1) (= y 2)))91 #t92 (let ((lst '()))93 (bind-list (push top pop)94 (list95 (lambda (xpr) (set! lst (cons xpr lst)))96 (lambda () (car lst))97 (lambda () (set! lst (cdr lst))))98 (push 0)99 (push 1)100 (pop)101 (top)))102 0103 (let ()104 (bind-list! (u v w))105 (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))106 #t107 )108 ;(lists-only?)109 110 12 (define stack #f) (define push! #f) (define pop! #f) 111 13 112 14 (define-checks (defines? verbose?) 113 (begin ;; reset internal database114 (bind-listify*)115 ;; add support for vectors and strings116 (bind-listify* vector? vector-car vector-cdr)117 (bind-listify* string? string-car string-cdr)118 #t)119 #t120 15 (let ((x #f) (y #f) (z #f)) 121 16 (bind! (x (y . z)) … … 200 95 #t 201 96 ) 202 ;(defines?) 97 ;(defines?) ; ok 203 98 204 99 (define-checks (binds? verbose?) 205 (begin ;; reset internal database206 (bind-listify*)207 ;; add support for vectors and strings208 (bind-listify* vector? vector-car vector-cdr)209 (bind-listify* string? string-car string-cdr)210 #t)211 #t212 100 (bind a 1 a) 101 1 102 (bind (a #f) '(1 #f) a) 213 103 1 214 104 (bind (a b) '(1 2) (list a b)) … … 239 129 '(1 2 3 4 5 #(6)) 240 130 241 (bind (as ... d e) '(1 2 3 4 5) (list as d e))242 '((1 2 3) 4 5)243 (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e))244 '(-1 0 (1 2 3) 4 5)245 (bind (x y as .. d e) '(-1 0 4 5) (list x y as d e))246 '(-1 0 () 4 5)247 (bind ((as (bs cs)) ... d e)248 '((1 (2 3)) (10 (20 30)) 4 5)249 (list as bs cs d e))250 '((1 10) (2 20) (3 30) 4 5)251 (bind ((as (bs cs)) ... d e)252 '((1 (2 3)) #(10 (20 30)) 4 5)253 (list as bs cs d e))254 '((1 10) (2 20) (3 30) 4 5)131 (bind (as ...) '(1 2 3) (list as)) 132 '((1 2 3)) 133 (bind (x y as ...) '(-1 0 1 2 3) (list x y as)) 134 '(-1 0 (1 2 3)) 135 (bind (x y as ..) '(-1 0) (list x y as)) 136 '(-1 0 ()) 137 (bind ((as (bs cs)) ...) 138 '((1 (2 3)) (10 (20 30))) 139 (list as bs cs)) 140 '((1 10) (2 20) (3 30)) 141 (bind ((as (bs cs)) ...) 142 '((1 (2 3)) #(10 (20 30))) 143 (list as bs cs)) 144 '((1 10) (2 20) (3 30)) 255 145 256 146 (bind-loop (x (a . b) y) '(5 #(1) 0) … … 312 202 #f 313 203 ) 314 ;(binds?) 315 ; 204 ;(binds?) ; ok 205 316 206 (define-checks (predicates? verbose?) 317 (begin ;; reset internal database318 (bind-listify*)319 ;; add support for vectors and strings320 (bind-listify* vector? vector-car vector-cdr)321 (bind-listify* string? string-car string-cdr)322 #t)323 #t324 207 ((bindable? (x)) '(name 1)) 325 208 #f … … 343 226 #t 344 227 ) 345 ;(predicates?) 228 ;(predicates?) ; ok 346 229 347 230 (define my-map #f) … … 350 233 351 234 (define-checks (cases? verbose?) 352 (begin ;; reset internal database353 (bind-listify*)354 ;; add support for vectors and strings355 (bind-listify* vector? vector-car vector-cdr)356 (bind-listify* string? string-car string-cdr)357 #t)358 #t359 235 (bind-case #() (() #f)) 360 236 #f … … 410 286 '(1 (2 . 3)) 411 287 (bind-case '#(1 2) 412 (() #f)288 ;(() #f) ;;;;;;; 413 289 ((a) #f) 414 290 ((a b) (list a b)) … … 417 293 418 294 (bind-case '(0 4) 419 ((a bs .... c) #f)420 ((a bs ... c) (list a bs c)))421 '(0 () 4)295 ((a bs ....) #f) 296 ((a bs ...) (list a bs))) 297 #f 422 298 (bind-case '(0 1 2 3 4) 423 ((a bs .. c) #f)424 ((a bs ... c) (list a bs c)))425 '(0 (1 2 3 ) 4)426 (bind-case '(0 #(1 (2 3)) 4)427 ((a (bs (cs (ds))) .. e) #f)428 ((a (bs (cs ds)) .. e) (list a bs cs ds e)))429 '(0 (1) (2) (3) 4)430 (bind-case '(0 4)431 ((a (bs (cs (ds))) .. e) (list a bs cs ds e))432 ((a (bs (cs ds)) .. e) #t))433 '(0 () () () 4)299 ((a bs ..) #f) 300 ((a bs ...) (list a bs))) 301 '(0 (1 2 3 4)) 302 (bind-case '(0 #(1 (2 3))) 303 ((a (bs (cs (ds))) ..) #f) 304 ((a (bs (cs ds)) ..) (list a bs cs ds))) 305 '(0 (1) (2) (3)) 306 (bind-case '(0) 307 ((a (bs (cs (ds))) ..) (list a bs cs ds)) 308 ((a (bs (cs ds)) ..) #t)) 309 '(0 () () ()) 434 310 (bind-case '((0 1 2 3) (10 #(20 30))) 435 311 (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs))) … … 441 317 (let loop ((lst lst) (result '())) 442 318 (bind-case lst 443 (() (reverse result)) 319 (() (reverse result)) ;;;;; 444 320 ((x . xs) 445 321 (loop xs (cons (fn x) result))))))) … … 453 329 (let loop ((vec vec)) 454 330 (bind-case vec 455 (() result) 331 (() result) ;;;;;;; 456 332 ((x . xs) 457 333 (vector-set! result … … 502 378 503 379 (bind-case '((0 1 2 3) (10 #(20 30))) 504 (((_ bs ... c) (_ (ys zs) ..)) (list bs cys zs)))505 '((1 2 ) 3(20) (30))380 (((_ bs ...) (_ (ys zs) ..)) (list bs ys zs))) 381 '((1 2 3) (20) (30)) 506 382 ) 507 383 ;(cases?) 508 384 509 385 (define-checks (lambdas? verbose?) 510 (begin ;; reset internal database511 (bind-listify*)512 ;; add support for vectors and strings513 (bind-listify* vector? vector-car vector-cdr)514 (bind-listify* string? string-car string-cdr)515 #t)516 #t517 386 ((bind-lambda (a (b cs ...) ds ...) 518 387 (list a b cs ds)) 519 388 '(1 #(20 30 40) 2 3)) 520 '(1 20 (30 40) (2 3))389 '(1 20 #(30 40) (2 3)) 521 390 ((bind-lambda (a (b (cs ds) ...) . es) 522 391 (list a b cs ds es)) 523 '(1 #(20 (30 40)) 2 3)) 392 '(1 (20 (30 40)) 2 3)) 393 ;'(1 #(20 (30 40)) 2 3)) 524 394 '(1 20 (30) (40) (2 3)) 525 395 ((bind-lambda (a (b . cs) . ds) … … 591 461 592 462 (define-checks (lets? verbose?) 593 (begin ;; reset internal database594 (bind-listify*)595 ;; add support for vectors and strings596 (bind-listify* vector? vector-car vector-cdr)597 (bind-listify* string? string-car string-cdr)598 #t)599 #t600 463 (bind-let ((((x y) z) '(#(1 2) 3)) 601 464 (u (+ 2 2)) … … 647 510 ;(lets?) 648 511 649 (import biglists)650 ;651 512 (define (integers-from n) 652 513 (Cons n (integers-from (+ n 1)) #f)) 653 514 (define integers (integers-from 0)) 654 (define (Car xs) (At 0 xs)) 655 (define (Cdr xs) (Drop 1 xs)) 515 (define 5integers (Take 5 integers)) 516 (define standard-checkers (sequence-db)) 517 (define checkers 518 ;; add finite lazy list handlers at the front 519 (sequence-db List? 520 Length 521 (lambda (xs k) (At k xs)) 522 (lambda (xs k) (Drop k xs)) 523 List 524 list?)) 656 525 657 526 (define-checks (biglists? verbose?) 658 (begin ;; reset internal database 659 (bind-listify*) 660 ;; add vector and biglist support 661 (bind-listify* vector? vector-car vector-cdr) 662 (bind-listify* BigList? Car Cdr) 663 #t) 664 #t 665 (bind (x y . zs) integers (Car zs)) 527 (if (memq List? standard-checkers) #t #f) 528 #f 529 (if (memq List? checkers) #t #f) 530 #t 531 (car checkers) 532 List? 533 (List? 5integers) 534 #t 535 (bind (x y . zs) 5integers (At 0 zs)) 666 536 2 667 (bind (_ _ . zs) integers (Carzs))537 (bind (_ _ . zs) 5integers (At 0 zs)) 668 538 2 669 539 (bind (x #f (_ (b . cs) . zs)) 670 (vector 1 #f (List 10 integers 2 3))671 (list x b ( Car cs) (Carzs) (At 1 zs)))540 (vector 1 #f (List 10 5integers 2 3)) 541 (list x b (At 0 cs) (At 0 zs) (At 1 zs))) 672 542 '(1 0 1 2 3) 673 543 ) 674 544 ;(biglists?) 675 545 676 (define-checks (dots? verbose?)677 (resolve-dots '(1 2 3) ...)678 '(1 2 3)679 (resolve-dots 1 2 '(30 40) .. 5)680 '(1 2 30 40 5)681 (resolve-dots 1 2 '() .. 5)682 '(1 2 5)683 (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)684 '(1 20 30 4 40 50 60 7)685 )686 ; (dots?)546 ;(define-checks (dots? verbose?) 547 ; (resolve-dots '(1 2 3) ...) 548 ; '(1 2 3) 549 ; (resolve-dots 1 2 '(30 40) .. 5) 550 ; '(1 2 30 40 5) 551 ; (resolve-dots 1 2 '() .. 5) 552 ; '(1 2 5) 553 ; (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7) 554 ; '(1 20 30 4 40 50 60 7) 555 ;) 556 ;;(dots?) 687 557 688 558 (check-all BINDINGS 689 (listify?)690 (lists-only?)691 559 (defines?) 692 560 (binds?) … … 696 564 (lets?) 697 565 (biglists?) 698 (dots?) 699 ) 700 566 ) 567 -
release/5/bindings/trunk/bindings.egg
r38814 r39398 1 ((synopsis "Pattern matching with destructuring bindings ")1 ((synopsis "Pattern matching with destructuring bindings and setters") 2 2 (category lang-exts) 3 3 (license "BSD") 4 4 (test-dependencies simple-tests biglists) 5 (dependencies simple-sequences) 5 6 (author "Juergen Lorenz") 6 (version " 4.1")7 (version "5.0") 7 8 (components (extension bindings 8 9 (csc-options "-O3" "-d0")))) -
release/5/bindings/trunk/bindings.scm
r38814 r39398 33 33 #|[ 34 34 Yet another implementation of the bindings egg. 35 It's based on the bind macro, which is a variant of Common Lisp's 36 destructuring bind. 37 38 It not only destructures nested pseudolists but nested sequences as 39 well, which can be vectors, strings, biglists or what have you, provided 40 you have added support for those datatypes. But that's as simple as 41 adding a triple seq? seq-car and seq-cdr to the generic transformer 42 procedure bind-listify*. As this name suggests, every sequence is 43 transformed to an ordinary list at each nesting level. Moreover, this 44 routine handles literals and dotted ends as well. 45 46 The bind macro itself uses bind-list 47 after having processed all literals and the wildcard, an underscore. The 48 rule is, the wildcard matches everything but doesn't bind anything, 49 whereas the literals match only itself, and, of course, don't bind 50 anything. 51 52 All other macros, in particular bind-case, a variant of match in the 53 matchable egg, are based on bind and are implemented as declarative 54 macros. 55 56 One difference to former versions of bind is, that it can be called 57 without a body which results in setting the pattern variables to 58 correspondig values in the nested sequence argument. In other words, 59 this is what was called bind! before. Hence bind! and 60 bind-define are expendable and code duplication is avoided. But for 61 convenience of use, this version is aliased bind! 35 Sequence routines are outsourced to simple-sequences, so that an 36 enhanced version of Paul Graham's dbind (On Lisp, p. 232) can be used, a 37 variant of Common Lisp's destructuring bind. 38 39 But this version of dbind supports setters as well, using dbind without 40 body. The reason to put it all in one huge macro is, that both variants 41 use a common set of subroutines, which are implemented within the macro 42 body. I could have put it into a helper module to be imported by syntax, 43 but this subroutines are without interest outside of dbind. 44 45 Other enhancements include length checks of sequences, a wildcard, _, 46 which matches everything and binds nothing, literals, which match only 47 themselfs but can't of course be bound, and dots, which are extensions of 48 ellipses: two dots accept zero or one items of the same shape as the 49 nested list to its left, and four dots accept only non-empty nested 50 lists. 51 52 Note, that dbind is not exported, but bind and bind! are exported 53 instead. 62 54 ]|# 63 55 64 56 (module bindings ( 65 bind-listify*66 bind-list67 bind-list!68 57 bind 69 58 bind! … … 82 71 bind/cc 83 72 bindings 84 vector-car85 vector-cdr86 vector-null?87 string-car88 string-cdr89 string-null?90 resolve-dots91 73 ) 92 74 93 75 (import scheme 76 (only simple-sequences sequence-db seq-ref seq-ref* seq-tail seq-length) 94 77 (only (chicken condition) condition-case) 95 (only (chicken base) assert cut subvector gensym void receive identityprint case-lambda error)78 (only (chicken base) gensym receive print case-lambda error) 96 79 (only (chicken keyword) keyword?) 97 (only (chicken format) format)80 (only (chicken module) reexport) 98 81 ) 99 82 100 (import-for-syntax (only (chicken keyword) keyword?) 101 (only (chicken format) format)) 102 103 (define vector-car (cut vector-ref <> 0)) 104 (define vector-cdr (cut subvector <> 1)) 105 (define (vector-null? vec) (zero? (vector-length vec))) 106 (define string-car (cut string-ref <> 0)) 107 (define string-cdr (cut substring <> 1)) 108 (define (string-null? str) (zero? (string-length str))) 109 110 (define (literal? x) 111 (or (boolean? x) 112 (string? x) 113 (char? x) 114 (number? x) 115 (keyword? x))) 116 117 (define (dots? xpr) 118 (and (symbol? xpr) 119 (if (memq xpr '(.. ... ....)) #t #f))) 120 121 (define (dotted-list? xpr) 122 (and (list? xpr) 123 (not (null? xpr)) 124 (dots? (car xpr)))) 125 126 ;;; (a b cs ... d e) 127 ;;; -> 128 ;;; (append (a) (b) cs (d) (e)) 129 ;;; to be used in body 130 (define-syntax resolve-dots 131 (ir-macro-transformer 132 (lambda (form inject compare?) 133 (let ((args (cdr form)) 134 (dots? (lambda (sym) 135 (or (compare? sym '..) 136 (compare? sym '...) 137 (compare? sym '....))))) 138 (let ((lists (let loop ((args args) (result '())) 139 (let loop ((args args) (result '())) 140 (cond 141 ((null? args) 142 (reverse result)) 143 ((null? (cdr args)) 144 (if (dots? (car args)) 145 (reverse result) 146 (reverse (cons `(list ,(car args)) result)))) 147 (else 148 (cond 149 ((dots? (cadr args)) 150 (loop (cdr args) 151 (cons (car args) result))) 152 ((dots? (car args)) 153 (loop (cdr args) result)) 154 (else 155 (loop (cdr args) 156 (cons `(list ,(car args)) 157 result))))) 158 ))))) 159 `(append ,@lists)))))) 160 161 ;;; (bind-listify*) 162 ;;; (bind-listify* seq) 163 ;;; (bind-listify* pat seq) 164 ;;; (bind-listify* seq? seq-car seq-cdr) 165 ;;; (bind-listify* seq? seq-car seq-cdr seq-null?) 166 ;;; ---------------------------------------------- 167 ;;; the first version resets the internal database, 168 ;;; the second returns the car-cdr-null? list corresponding to seq, 169 ;;; the third does the actual work transforming seq to a nested list 170 ;;; and the last two add support for a new sequence type. 171 (define bind-listify* 172 (let ((db (list (cons (lambda (x) #t) 173 (list car cdr null?))))) 174 (case-lambda 175 (() (set! db ; reset 176 (list (cons (lambda (x) #t) 177 (list car cdr null?))))) 178 ((seq) 179 (let loop ((db db)) 180 (if ((caar db) seq) 181 (cdar db) 182 (loop (cdr db))))) 183 ((pat seq) 184 (let ((gstop (gensym 'stop)) 185 (seq-car (car (bind-listify* seq))) 186 (accessors (bind-listify* seq))) 187 (let ((seq-cdr (cadr accessors)) 188 (seq-null? 189 (if (null? (cddr accessors)) 190 (lambda (seq) 191 (eq? (condition-case (seq-car seq) 192 ((exn) gstop)) 193 gstop)) 194 (caddr accessors)))) 195 (let loop ((pat pat) (seq seq) (result '())) 196 (cond 197 ((null? pat) 198 (if (seq-null? seq) 199 (reverse result) 200 (error 'bind-listify* "length mismatch" pat seq))) 201 ((and (pair? pat) (dotted-list? (cdr pat))) ; new 202 (let ((pfirst (car pat)) 203 (len (- (let iloop ((seq seq) (result 0)) 204 (if (seq-null? seq) 205 result 206 (iloop (seq-cdr seq) (+ result 1)))) 207 (length (cddr pat))))) 208 (receive (head tail) 209 (let iloop ((tail seq) (k 0) (head '())) 210 (cond 211 ((seq-null? tail) 212 (values (reverse head) tail)) 213 ((= k len) 214 (values (reverse head) tail)) 215 (else 216 (iloop (seq-cdr tail) 217 (+ k 1) 218 (cons (seq-car tail) head))))) 219 ;(print "HHH" head) 220 (case (cadr pat) 221 ((..) 222 (assert (or (null? head) (null? (cdr head))))) 223 ((...) 224 (assert #t)) 225 ((....) 226 (assert (pair? head))) 227 (else 'bind-listify* "can't happen")) 228 (cond 229 ((symbol? pfirst) 230 (if (eq? pfirst '_) 231 (error 'bind-listify* 232 "dots mustn't follow wildcard") 233 (append 234 (reverse result) 235 (cons head 236 (bind-listify* (cddr pat) tail))))) 237 ((literal? pfirst) 238 (error 'bind-listify* 239 "dots mustn't follow literal")) 240 ((pair? pfirst) 241 (assert (all-bindable? pfirst head)) 242 (letrec 243 ((recompose 244 (lambda (pat seq) 245 ;;; (a (b c)) ((1 (10 100)) (2 (20 200))) 246 ;;; -> 247 ;;; (a (b c)) ((1 2) ((10 20) (100 200))) 248 (cond 249 ((null? pat) '()) 250 ((symbol? pat) seq) 251 (else 252 (let ((pf (car pat)) 253 (lf (map car 254 (map (lambda (s) 255 (bind-listify* 256 pat s)) 257 seq))) 258 (pr (cdr pat)) 259 (lr (map cdr 260 (map (lambda (s) 261 (bind-listify* 262 pat s)) 263 seq)))) 264 (if (pair? pf) 265 (cons (recompose pf lf) (recompose pr lr)) 266 (cons lf (recompose pr lr))))))))) 267 (append 268 (reverse result) 269 (cons (recompose pfirst head) 270 (bind-listify* (cddr pat) tail))))) 271 )))) 272 ((pair? pat) 273 (let ((pfirst (car pat)) 274 (prest (cdr pat)) 275 (sfirst (seq-car seq)) 276 (srest (seq-cdr seq))) 277 (cond 278 ((and (symbol? pfirst) (eq? pfirst '_)) 279 (loop prest srest result)) 280 ((symbol? pfirst) 281 (loop prest srest (cons sfirst result))) 282 ((null? pfirst) ;;; 283 (if (seq-null? sfirst) 284 (loop prest 285 srest 286 (cons (bind-listify* pfirst sfirst) result)) 287 (error 'bind-listify* "length mismatch" 288 pfirst sfirst))) 289 ((literal? pfirst) 290 (if (equal? pfirst sfirst) 291 (loop prest srest result) 292 (error 'bind-listify* 293 (format #f "literals ~s and ~s not equal?~%" 294 pfirst sfirst)))) 295 ((pair? pfirst) 296 (loop prest 297 srest 298 (cons (bind-listify* pfirst sfirst) result))) 299 (else (error 'bind-listify* 300 (format #f "~s is not a valid literal~%") 301 pfirst)) 302 ))) 303 (else 304 (cond 305 ((and (symbol? pat) (eq? pat '_)) 306 (reverse result)) 307 ((symbol? pat) 308 (reverse (cons seq result))) 309 ((literal? pat) 310 (if (equal? pat seq) 311 (reverse result) 312 (error 'bind-listify* 313 (format #f "literals ~s and ~s not equal?~%" 314 pat seq)))) 315 (else (error 'bind-listify* 316 (format #f "~s is not a valid literal~%") 317 pat)) 318 ))))))) 319 ((seq? seq-car seq-cdr) 320 (set! db (cons (cons seq? 321 (list seq-car seq-cdr)) db))) 322 ((seq? seq-car seq-cdr seq-null?) 323 (set! db (cons (cons seq? 324 (list seq-car seq-cdr seq-null?)) db))) 325 ))) 326 327 ;;; (bind-list pat lst) 328 ;;; (bind-list pat lst xpr . xprs) 329 ;;; ------------------------------ 330 ;;; nested versions of bind (symbol-lists only) 331 (define-syntax bind-list 332 (ir-macro-transformer 333 (lambda (form inject compare?) 334 (let ((pat (cadr form)) 335 (lst (caddr form)) 336 (body (cdddr form)) 337 ) 338 (let* ( 339 ;; (a (b c) d) -> (a (g b c) d) 340 (pat* (map (lambda (s) 341 (if (symbol? s) 342 s 343 (cons (gensym) s))) 344 pat)) 345 ;; (a (b c) d) -> (a g d) 346 (flat-pat* (map (lambda (s) 347 (if (symbol? s) 348 s 349 (car s))) 350 pat*)) 351 ) 352 ;(print pat " " pat* " " flat-pat*) 353 (receive (pairs syms) ; filter 354 ;; (a (g b c) d) -> ((g b c)) (a d) 355 (let loop ((lst pat*) (yes '()) (no '())) 356 (cond 357 ((null? lst) 358 (values (reverse yes) (reverse no))) 359 ((pair? (car lst)) 360 (loop (cdr lst) (cons (car lst) yes) no)) 361 ((symbol? (car lst)) 362 (loop (cdr lst) yes (cons (car lst) no))) 363 (else (error 'bind-list "can't happen")))) 364 ;(print pairs " PS " syms) 365 (if (null? body) 366 ;; without body, i.e. multiple set! 367 (if (null? pairs) ; flat list 368 `(if (= (length ',syms) (length ,lst)) 369 ,(let loop ((pat syms) (lst lst) (result '(begin))) 370 (if (null? pat) 371 (reverse result) 372 (loop (cdr pat) 373 `(cdr ,lst) 374 (cons `(set! ,(car pat) (car ,lst)) result)))) 375 (error 'bind-list "length mismatch" ',pat ,lst)) 376 ;; (bind-list (a (b c)) '(1 (2 3))) 377 ;; -> 378 ;; (begin (bind-list (a g) lst) 379 ;; (bind-list (b c) g)) 380 `(begin (bind-list ,flat-pat* ,lst) 381 ,@(map (lambda (pair) 382 `(bind-list ,(cdr pair) ,(car pair))) 383 pairs))) 384 ;; with body 385 (if (null? pairs) ; flat list 386 `(apply (lambda ,syms ,@body) 387 ,lst) 388 ;; (bind-list* (a (b c)) '(1 (2 3)) body) 389 ;; -> 390 ;; (apply (lambda (a g) (bind-list* (b c) g body)) 391 ;; lst) 392 `(apply 393 (lambda ,flat-pat* 394 ,(let loop ((pairs pairs)) 395 (if (null? pairs) 396 `(begin ,@body) 397 `(bind-list ,(cdar pairs) 398 ,(caar pairs) 399 ,(loop (cdr pairs)))))) 400 ,lst)) 401 ))))))) 402 403 ;;; (bind-list! pat) 404 ;;; (bind-list! pat lst) 405 ;;; -------------------- 406 ;;; list version of bind! 407 (define-syntax bind-list! 408 (syntax-rules () 409 ((_ pat lst) 410 (bind-list pat lst)) 411 ((_ pat) 412 (bind-list pat 'pat)) 413 )) 414 415 ;;; (bind pat seq) 416 ;;; (bind pat seq . body) 417 ;;; --------------------- 418 ;;; Note, that the destructuring of pat and seq happen at different 419 ;;; times: The former at compile-time, the latter at run-time. 420 ;;; Consequently, some code in bind almost duplicates some code in 421 ;;; bind-listify*. 422 (define-syntax bind 83 (reexport (only simple-sequences sequence-db)) 84 85 (import-for-syntax (only (chicken keyword) keyword?)) 86 87 ;;; Graham's dbind for sequences with length checks, literals, 88 ;;; wildcard and dots, as well as setters. 89 (define-syntax dbind 423 90 (er-macro-transformer 424 91 (lambda (form rename compare?) 425 92 (let ( 426 (pat (cadr form)) 427 (seq (caddr form)) 428 (body (cdddr form)) 93 (%x (rename 'x)) 429 94 (%_ (rename '_)) 430 (%bind-list (rename 'bind-list)) 431 (%bind-listify* (rename 'bind-listify*)) 432 (literal? (lambda (x) 433 (or (boolean? x) 434 (string? x) 435 (char? x) 436 (number? x) 437 (keyword? x)))) 438 (dotted-list? (lambda (x) 439 (and (list? x) 440 (not (null? x)) 441 (if (memq (car x) '(.. ... ....)) 442 #t #f)))) 95 (%.. (rename '..)) 96 (%... (rename '...)) 97 (%.... (rename '....)) 98 (%if (rename 'if)) 99 (%or (rename 'or)) 100 (%map (rename 'map)) 101 (%let (rename 'let)) 102 (%set! (rename 'set!)) 103 (%begin (rename 'begin)) 104 (%error (rename 'error)) 105 (%zero? (rename 'zero?)) 106 (%equal? (rename 'equal?)) 107 (%lambda (rename 'lambda)) 108 (%seq-ref (rename 'seq-ref)) 109 (%seq-ref* (rename 'seq-ref*)) 110 (%seq-tail (rename 'seq-tail)) 111 (%seq-length (rename 'seq-length)) 112 (%positive? (rename 'positive?)) 443 113 ) 444 114 (letrec ( 445 (listify* 115 (literal? 116 (lambda (p) 117 (or (boolean? p) 118 (char? p) 119 (number? p) 120 (string? p) 121 (keyword? p)))) 122 (mappend 123 (lambda (fn lists) 124 (apply append (map fn lists)))) 125 (dots? 126 (lambda (sym) 127 (or (compare? sym %..) 128 (compare? sym %...) 129 (compare? sym %....)))) 130 (check-dots 131 (lambda (sym seq) 132 `(,(gensym) 133 (,%if 134 ,(cond 135 ((compare? sym %..) 136 `(,%or (,%zero? (,%seq-length ,seq)) 137 (,%zero? (,%seq-length (,%seq-tail ,seq 1))))) 138 ((compare? sym %...) #t) 139 ((compare? sym %....) 140 `(,%positive? (,%seq-length ,seq)))) 141 (,%seq-length ,seq) 142 (,%error 'check-dots "wrong size for this dots" ,seq ',sym))))) 143 (indices 144 ;;; (a b) -> ((a . 0) (b . 1)) 145 ;;; (a (b (c))) -> ((a . 0) (b 1 . 0) (c 1 1 . 0)) 446 146 (lambda (pat) 447 (let loop ((pat pat) (result '())) 448 (cond 449 ((null? pat) 450 (reverse result)) 451 ((and (symbol? pat) ;(eq? pat '_)) 452 (compare? pat %_)) 453 (reverse result)) 454 ((symbol? pat) 455 (reverse (cons pat result))) 456 ((literal? pat) 457 (reverse result)) 458 ((and (pair? pat) (dotted-list? (cdr pat))) 459 (let ((first (car pat)) (rest (cdr pat))) 460 (cond 461 ((and (symbol? first) (eq? first '_)) 462 (error 'bind "dots mustn't follow wildcard")) 463 ((symbol? first) 464 (loop (cdr rest) (cons first result))) 465 ((literal? first) 466 (error 'bind "dots mustn't follow literal")) 467 ((pair? first) 468 (loop (cdr rest) (cons (listify* first) result))) 469 ))) 470 ((pair? pat) 471 (let ((first (car pat)) (rest (cdr pat))) 472 (cond 473 ((and (symbol? first) ;(eq? first '_)) 474 (compare? first %_)) 475 (loop rest result)) 476 ((symbol? first) 477 (loop rest (cons first result))) 478 ((null? first) ;;; 479 (loop rest (cons first result))) 480 ((literal? first) 481 (loop rest result)) 482 ((pair? first) 483 (loop rest (cons (listify* first) result))) 484 ))) 485 )))) 147 (receive (flat ind) 148 (let recur ((pat pat) (k 0)) 149 (cond 150 ((null? pat) 151 (values '() '())) 152 ((pair? pat) 153 (let ((p (car pat)) (ps (cdr pat))) 154 (receive (p* i*) (recur p 0) 155 (receive (ps* is*) (recur ps (+ k 1)) 156 (if (pair? p) 157 (values (append p* ps*) 158 (append (map (lambda (x) (cons k x)) i*) 159 is*)) 160 (values (cons p ps*) 161 (cons k is*))))))) 162 (else ;symbol 163 (values '() '())))) 164 (map cons flat ind)))) 165 (map-seq-ref* 166 ;;; '(a (b c)) '((1 (2 3)) (10 (20 30))) 167 ;;; -> 168 ;;; '((a (1 10))) (b (2 30)) (c (3 30))) 169 (lambda (pat seqs) 170 (let recur ((pi (indices pat))) 171 (if (null? pi) 172 '() 173 (let ((api (car pi)) (dpi (cdr pi))) 174 (cons (list (car api) 175 `(,%map (,%lambda (,%x) 176 (,%seq-ref* ,%x ',(cdr api))) 177 ,seqs)) 178 (recur dpi))))))) 179 (destruc 180 ;; (destruc '(a (b . c) . d) 'seq) 181 ;; -> 182 ;; ((a (seq 0)) 183 ;; ((#!g (seq 1)) (b (#!g 0)) (c (#!g 1 #f))) 184 ;; (d (seq 2 #f))) 185 (lambda (pat seq) 186 (let loop ((pat pat) (seq seq) (n 0)) 187 (if (pair? pat) 188 (let ((p (car pat)) 189 (q (cdr pat)) 190 (recu (loop (cdr pat) seq (+ n 1)))) 191 (cond 192 ((symbol? p) 193 (cond 194 ((compare? p %_) ; wildcard 195 recu) 196 ((and (pair? q) (dots? (car q))) ;;;; 197 ;(print p " PQ " q) 198 (let ((seqs `(,%seq-tail ,seq ,n))) 199 ;(cons (list p seqs) '()))) ;ok, ohne checks 200 (cons (list (check-dots (car q) seqs) 201 (list p seqs)) 202 '()))) 203 (else 204 (cons `(,p (,%seq-ref ,seq ,n)) recu)))) 205 ;; literals 206 ((literal? p) 207 (cons `(,(gensym) 208 (,%if (,%equal? (,%seq-ref ,seq ,n) ,p) 209 #t 210 (,%error 'dbind 211 "literals don't match" 212 (,%seq-ref ,seq ,n) ,p))) 213 recu)) 214 ;; pair 215 (else 216 (cond 217 ((and (pair? q) (dots? (car q))) ;;;;; 218 (let ((seqs `(,%seq-tail ,seq ,n))) 219 (cons (cons (check-dots (car q) seqs) 220 (map-seq-ref* p seqs)) 221 '()))) 222 (else 223 (let ((g (gensym))) 224 (cons (cons `(,g (,%seq-ref ,seq ,n)) 225 (loop p g 0)) 226 recu)))))) ) 227 (let ((tail `(,%seq-tail ,seq ,n))) 228 (cond 229 ((null? pat) 230 `((,(gensym) 231 (,%if (,%zero? (,%seq-length ,tail)) 232 #t 233 (,%error 'dbind 234 "tail not empty?" 235 ,tail))))) 236 ((literal? pat) ;;;;;; 237 `((,(gensym) 238 (,%if (,%equal? (,%seq-tail ,seq ,n) ,pat) 239 #t 240 (,%error 'dbind 241 "literals don't match" 242 (,%seq-tail ,seq ,n) ,pat))))) 243 (else `((,pat ,tail))))))))) 244 (dbind-ex 245 ;; -> 246 ;; (let ((a (seq 0)) (#!g (seq 1)) (d (seq 2 #f))) 247 ;; (let ((b (#!g 0)) (c (#!g 1 #f))) 248 ;; (begin body))) 249 (lambda (binds body) 250 (if (null? binds) 251 `(,%begin ,@body) 252 `(,%let ,(map (lambda (b) 253 (if (pair? (car b)) (car b) b)) 254 binds) 255 ,(dbind-ex (mappend (lambda (b) 256 (if (pair? (car b)) 257 (cdr b) 258 '())) 259 binds) 260 body))))) 261 (dbind-set 262 ;; -> 263 ;; (begin 264 ;; (set! a (seq 0)) (set! #!g (seq 1)) (set! d (seq 2 #f)) 265 ;; (set! b (#!g 0)) (set! c (#!g 1 #f))) 266 (lambda (binds) 267 (mappend (lambda (b) 268 (if (pair? (car b)) 269 (cons `(,%set! ,(caar b) ,(cadar b)) 270 (dbind-set (cdr b))) 271 (list `(,%set! ,(car b) ,(cadr b))))) 272 binds))) 486 273 ) 487 (if (null? body) 488 ;; without body 489 `(,%bind-list ,(listify* pat) 490 (,%bind-listify* ',pat ,seq)) 491 ;; with body 492 (let ((xpr (car body)) (xprs (cdr body))) 493 `(,%bind-list ,(listify* pat) 494 (,%bind-listify* ',pat ,seq) 495 ,xpr ,@xprs))) 496 ))))) 274 (let ((pat (cadr form)) 275 (seq (caddr form)) 276 (body (cdddr form)) 277 (gseq (gensym 'seq))) 278 `(,%let ((,gseq ,seq)) 279 ,(if (null? body) 280 ;; setters 281 (cond 282 ((null? pat) 283 `(,%if (,%zero? (,%seq-length ,gseq)) 284 (,%if #f #f) 285 (,%error 'dbind "seq too long" ,gseq ',pat))) 286 ((compare? pat %_) 287 `(,%if #f #f)) 288 ((literal? pat) 289 `(,%if (,%equal? ,pat ,gseq) 290 (,%if #f #f) 291 (,%error 'dbind "literals don't match" 292 ,pat ,gseq))) 293 ((symbol? pat) 294 `(,%set! ,pat ,gseq)) 295 ((pair? pat) 296 `(,%begin ,@(dbind-set (destruc pat gseq))))) 297 ;; binders 298 (cond 299 ((null? pat) 300 `(,%if (,%zero? (,%seq-length ,gseq)) 301 (,%begin ,@body) 302 (,%error 'dbind "seq too long" ,gseq ',pat))) 303 ((compare? pat %_) 304 `(,%begin ,@body)) 305 ((literal? pat) 306 `(,%if (,%equal? ,pat ,gseq) 307 (,%begin ,@body) 308 (,%error 'dbind "literals don't match" 309 ,pat ,gseq))) 310 ((symbol? pat) 311 `(,%let ((,pat ,gseq)) ,@body)) 312 ((pair? pat) 313 (dbind-ex (destruc pat gseq) body))) 314 )))))))) 315 316 ;;; (bind pat seq xpr . xprs) 317 ;;; ------------------------- 318 ;;; binds pattern variables of pat to corresponding places in seq 319 ;;; and executes body xpr . xprs in this context. 320 ;;; Literals, wildcard, length checks and dots are supported. 321 (define-syntax bind 322 (syntax-rules () 323 ((_ pat seq xpr . xprs) 324 (dbind pat seq xpr . xprs)))) 497 325 498 326 ;;; (bind! pat seq) 499 327 ;;; (bind! pat) 500 328 ;;; --------------- 501 ;;; alias to bind without body329 ;;; setters corresponding to bind 502 330 (define-syntax bind! 503 331 (syntax-rules () 504 332 ((_ pat seq) 505 ( bind pat seq))333 (dbind pat seq)) 506 334 ((_ pat) 507 ( bind pat 'pat))))335 (dbind pat 'pat)))) 508 336 509 337 ;;; (bindable? pat (where . fenders) seq) … … 515 343 (syntax-rules (where) 516 344 ((_ pat (where fender ...) seq) 517 (condition-case ( bind pat seq (and fender ...))345 (condition-case (dbind pat seq (and fender ...)) 518 346 ((exn) #f))) 519 347 ((_ pat seq) 520 (condition-case ( bind pat seq #t)348 (condition-case (dbind pat seq #t) 521 349 ((exn) #f))) 522 350 ;; curried versions … … 567 395 ((_ seq (pat (where fender ...) xpr . xprs)) 568 396 (if (bindable? pat (where fender ...) seq) 569 ( bind pat seq xpr . xprs)397 (dbind pat seq xpr . xprs) 570 398 (error 'bind-seq "sequence doesn't match pattern with fenders" 571 399 seq 'pat 'fender ...))) 572 400 ((_ seq (pat xpr . xprs)) 573 401 (if (bindable? pat seq) 574 ( bind pat seq xpr . xprs)402 (dbind pat seq xpr . xprs) 575 403 (error 'bind-seq "sequence doesn't match pattern" seq 'pat))) 576 404 ((_ seq (pat (where fender ...) xpr . xprs) . clauses) 577 405 (if (bindable? pat (where fender ...) seq) 578 ( bind pat seq xpr . xprs)406 (dbind pat seq xpr . xprs) 579 407 (bind-case seq . clauses))) 580 408 ((_ seq (pat xpr . xprs) . clauses) 581 409 (if (bindable? pat seq) 582 ( bind pat seq xpr . xprs)410 (dbind pat seq xpr . xprs) 583 411 (bind-case seq . clauses))) 584 412 )) … … 605 433 (syntax-rules () 606 434 ((_ pat xpr . xprs) 607 (lambda (x) ( bind pat x xpr . xprs)))435 (lambda (x) (dbind pat x xpr . xprs))) 608 436 )) 609 437 … … 614 442 (syntax-rules () 615 443 ((_ pat xpr . xprs) 616 (lambda x ( bind pat x xpr . xprs)))444 (lambda x (dbind pat x xpr . xprs))) 617 445 )) 618 446 … … 685 513 686 514 ;;; (bind-loop pat seq xpr ....) 687 ;;; ---- 515 ;;; ---------------------------- 688 516 ;;; anaphoric version of bind, introducing loop routine behind the scene 689 517 (define-syntax bind-loop … … 745 573 (let () xpr . xprs)) 746 574 ((_ ((pat seq)) xpr . xprs) 747 ( bind pat seq xpr . xprs))575 (dbind pat seq xpr . xprs)) 748 576 ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs) 749 ( bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))577 (dbind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs))) 750 578 )) 751 579 … … 757 585 (syntax-rules () 758 586 ((_ ((pat seq) ...) xpr . xprs) 759 ( bind (pat ...) (list seq ...) xpr . xprs))587 (dbind (pat ...) (list seq ...) xpr . xprs)) 760 588 ((_ name ((pat seq) ...) xpr . xprs) 761 589 ((letrec ((name (bind-lambda* (pat ...) xpr . xprs))) … … 780 608 (syntax-rules () 781 609 ((_ pat seq xpr . xprs) 782 ( bind pat 'pat610 (dbind pat 'pat 783 611 (bind! pat seq) 784 612 xpr . xprs)))) … … 816 644 (define bindings 817 645 (symbol-dispatcher '( 646 (sequence-db 647 procedure: 648 (sequence-db) 649 (sequence-db seq) 650 (sequence-db seq? seq-length seq-ref seq-tail seq-maker . pos?) 651 "sequence database processing, reexported from simple-sequences:" 652 "the first resets the database to the standard with" 653 "lists, pairs, vectors and strings," 654 "the second returns the vector of handlers as well as the discriminator," 655 "the third adds a new database record either at the end or before the" 656 "pos? discriminator." 657 "A record cosists of a discriminator, seq?, and a vector with items" 658 "seq-lenth, seq-ref, seq-tail and seq-maker patterned after vectors." 659 "Note, that the last record can handle atoms, albeit it is not a" 660 "sequence." 661 ) 818 662 (bindings 819 663 procedure: 820 664 (bindings sym ..) 821 665 "documentation procedure") 822 (bind-listify*823 generic procedure:824 (bind-listify*)825 (bind-listify* seq)826 (bind-listify* pat seq)827 (bind-listify* seq? seq-car seq-cdr)828 (bind-listify* seq? seq-car seq-cdr seq-null?)829 "the first resets the internal database for lists only"830 "the second returns the car-cdr-pair corresponding to seq"831 "the third transforms the nested pseudolist seq to a nested list"832 "and the last two add support for a new sequence type to the"833 "internal database, where seq-null? is needed only if"834 "seq-car doesn't raise an exception on an empty sequence")835 (bind-list836 macro:837 (bind-list pat lst)838 (bind-list pat lst . body)839 "list version of bind: destructure nested symbol-lists only")840 (bind-list!841 macro:842 (bind-list! pat lst)843 (bind-list! pat)844 "the former is an alias to bind-list wtihout body"845 "the latter alias to (bind-list! pat 'pat)")846 666 (bind 847 667 macro: … … 918 738 "binds cc to the current contiunation" 919 739 "and execute xpr ... in this context") 920 (resolve-dots921 macro:922 (resolve-dots . args)923 "where args is a list of items which might be followed by dots."924 "The item before dots must be a list, which is spliced into"925 "the resulting list removing the dots")926 (vector-car927 procedure:928 (vector-car vec)929 "vector-analog of car")930 (vector-cdr931 procedure:932 (vector-cdr vec)933 "vector-analog of cdr")934 (vector-null?935 procedure:936 (vector-null? vec)937 "vector-analog of null?")938 (string-car939 procedure:940 (string-car str)941 "string-analog of car")942 (string-cdr943 procedure:944 (string-cdr str)945 "string-analog of cdr")946 (string-null?947 procedure:948 (string-null? str)949 "string-analog of null?")950 740 ))) 951 741 952 742 ) ; module 953 743 954 ;(import bindings simple-tests)955 -
release/5/bindings/trunk/tests/run.scm
r38814 r39398 7 7 (chicken base) 8 8 (chicken condition) 9 biglists 9 10 ) 10 11 11 (define-checks (listify? verbose?)12 (begin ;; reset internal database13 (bind-listify*)14 ;; add support for vectors and strings15 (bind-listify* vector? vector-car vector-cdr)16 (bind-listify* string? string-car string-cdr)17 #t)18 #t19 (bind-listify* "x")20 (list string-car string-cdr)21 (bind-listify* 'a 1)22 '(1)23 (bind-listify* '(a . as) #(1 2 3))24 '(1 #(2 3))25 (bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))26 '(1 (2) 3)27 (bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))28 '(1 (2 (3 (300)) 4) #(50))29 (bind-listify* '(a (_ b _) c) '(1 (20 30 40) 5))30 '(1 (30) 5)31 (bind-listify* '(a (_ b _) . c) '(1 (20 30 40) 5))32 '(1 (30) (5))33 (bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))34 '(1 (30) (5))35 (bind-listify* '(a (_ b _) . c) '(1 "xyz" 5))36 '(1 (#\y) (5))37 (bind-listify* '(x) "x")38 '(#\x)39 (bind-listify* '(x . y) "xyz")40 '(#\x "yz")41 (bind-listify* 'x 1)42 '(1)43 (bind-listify* '(x) #(1))44 '(1)45 (bind-listify* '(x . y) #(1 2 3))46 '(1 #(2 3))47 (bind-listify* '(#f ()) #(#f #()))48 '(())49 (bind-listify* '(as ... b c) '(1 2 3 40 50))50 '((1 2 3) 40 50)51 (bind-listify* '(as ... b c) '(40 50))52 '(() 40 50)53 (bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))54 '(-2 -1 (1 2 3) 40 50)55 (bind-listify* '(x y as ... b c) '(-2 -1 40 50))56 '(-2 -1 () 40 50)57 (bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))58 '(((1 10) ((2 20) (3 30))) 4 5)59 (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) (10 (20 30)) 4 5))60 '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)61 (bind-listify* '(x y (as (bs cs)) ... d e) #(-1 0 (1 (2 3)) (10 (20 30)) 4 5))62 '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)63 (bind-listify* '(x y (as (bs cs)) ... d e) '(-1 0 (1 (2 3)) #(10 (20 30)) 4 5))64 '(-1 0 ((1 10) ((2 20) (3 30))) 4 5)65 (bind-listify* '(x y (as (bs (cs))) ... d e)66 '(-1 0 (1 (2 (3))) #(10 (20 (30))) 4 5))67 '(-1 0 ((1 10) ((2 20) ((3 30)))) 4 5)68 )69 ;(listify?)70 71 (define-checks (lists-only? verbose?)72 (begin ;; reset internal database73 (bind-listify*)74 #t)75 #t76 ;; this would work with string support:77 (condition-case (bind (x) "x" x)78 ((exn) #f))79 #f80 (bind-list (a b) '(1 2) (list a b))81 '(1 2)82 (bind-list (x (y (z))) '(1 (2 (3))) (list x y z))83 '(1 2 3)84 (let ((x #f) (y #f))85 (bind-list (x y) '(1 2))86 (and (= x 1) (= y 2)))87 #t88 (let ((x #f) (y #f))89 (bind-list (x (y)) '(1 (2)))90 (and (= x 1) (= y 2)))91 #t92 (let ((lst '()))93 (bind-list (push top pop)94 (list95 (lambda (xpr) (set! lst (cons xpr lst)))96 (lambda () (car lst))97 (lambda () (set! lst (cdr lst))))98 (push 0)99 (push 1)100 (pop)101 (top)))102 0103 (let ()104 (bind-list! (u v w))105 (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))106 #t107 )108 ;(lists-only?)109 110 12 (define stack #f) (define push! #f) (define pop! #f) 111 13 112 14 (define-checks (defines? verbose?) 113 (begin ;; reset internal database114 (bind-listify*)115 ;; add support for vectors and strings116 (bind-listify* vector? vector-car vector-cdr)117 (bind-listify* string? string-car string-cdr)118 #t)119 #t120 15 (let ((x #f) (y #f) (z #f)) 121 16 (bind! (x (y . z)) … … 200 95 #t 201 96 ) 202 ;(defines?) 97 ;(defines?) ; ok 203 98 204 99 (define-checks (binds? verbose?) 205 (begin ;; reset internal database206 (bind-listify*)207 ;; add support for vectors and strings208 (bind-listify* vector? vector-car vector-cdr)209 (bind-listify* string? string-car string-cdr)210 #t)211 #t212 100 (bind a 1 a) 101 1 102 (bind (a #f) '(1 #f) a) 213 103 1 214 104 (bind (a b) '(1 2) (list a b)) … … 239 129 '(1 2 3 4 5 #(6)) 240 130 241 (bind (as ... d e) '(1 2 3 4 5) (list as d e))242 '((1 2 3) 4 5)243 (bind (x y as ... d e) '(-1 0 1 2 3 4 5) (list x y as d e))244 '(-1 0 (1 2 3) 4 5)245 (bind (x y as .. d e) '(-1 0 4 5) (list x y as d e))246 '(-1 0 () 4 5)247 (bind ((as (bs cs)) ... d e)248 '((1 (2 3)) (10 (20 30)) 4 5)249 (list as bs cs d e))250 '((1 10) (2 20) (3 30) 4 5)251 (bind ((as (bs cs)) ... d e)252 '((1 (2 3)) #(10 (20 30)) 4 5)253 (list as bs cs d e))254 '((1 10) (2 20) (3 30) 4 5)131 (bind (as ...) '(1 2 3) (list as)) 132 '((1 2 3)) 133 (bind (x y as ...) '(-1 0 1 2 3) (list x y as)) 134 '(-1 0 (1 2 3)) 135 (bind (x y as ..) '(-1 0) (list x y as)) 136 '(-1 0 ()) 137 (bind ((as (bs cs)) ...) 138 '((1 (2 3)) (10 (20 30))) 139 (list as bs cs)) 140 '((1 10) (2 20) (3 30)) 141 (bind ((as (bs cs)) ...) 142 '((1 (2 3)) #(10 (20 30))) 143 (list as bs cs)) 144 '((1 10) (2 20) (3 30)) 255 145 256 146 (bind-loop (x (a . b) y) '(5 #(1) 0) … … 312 202 #f 313 203 ) 314 ;(binds?) 315 ; 204 ;(binds?) ; ok 205 316 206 (define-checks (predicates? verbose?) 317 (begin ;; reset internal database318 (bind-listify*)319 ;; add support for vectors and strings320 (bind-listify* vector? vector-car vector-cdr)321 (bind-listify* string? string-car string-cdr)322 #t)323 #t324 207 ((bindable? (x)) '(name 1)) 325 208 #f … … 343 226 #t 344 227 ) 345 ;(predicates?) 228 ;(predicates?) ; ok 346 229 347 230 (define my-map #f) … … 350 233 351 234 (define-checks (cases? verbose?) 352 (begin ;; reset internal database353 (bind-listify*)354 ;; add support for vectors and strings355 (bind-listify* vector? vector-car vector-cdr)356 (bind-listify* string? string-car string-cdr)357 #t)358 #t359 235 (bind-case #() (() #f)) 360 236 #f … … 410 286 '(1 (2 . 3)) 411 287 (bind-case '#(1 2) 412 (() #f)288 ;(() #f) ;;;;;;; 413 289 ((a) #f) 414 290 ((a b) (list a b)) … … 417 293 418 294 (bind-case '(0 4) 419 ((a bs .... c) #f)420 ((a bs ... c) (list a bs c)))421 '(0 () 4)295 ((a bs ....) #f) 296 ((a bs ...) (list a bs))) 297 #f 422 298 (bind-case '(0 1 2 3 4) 423 ((a bs .. c) #f)424 ((a bs ... c) (list a bs c)))425 '(0 (1 2 3 ) 4)426 (bind-case '(0 #(1 (2 3)) 4)427 ((a (bs (cs (ds))) .. e) #f)428 ((a (bs (cs ds)) .. e) (list a bs cs ds e)))429 '(0 (1) (2) (3) 4)430 (bind-case '(0 4)431 ((a (bs (cs (ds))) .. e) (list a bs cs ds e))432 ((a (bs (cs ds)) .. e) #t))433 '(0 () () () 4)299 ((a bs ..) #f) 300 ((a bs ...) (list a bs))) 301 '(0 (1 2 3 4)) 302 (bind-case '(0 #(1 (2 3))) 303 ((a (bs (cs (ds))) ..) #f) 304 ((a (bs (cs ds)) ..) (list a bs cs ds))) 305 '(0 (1) (2) (3)) 306 (bind-case '(0) 307 ((a (bs (cs (ds))) ..) (list a bs cs ds)) 308 ((a (bs (cs ds)) ..) #t)) 309 '(0 () () ()) 434 310 (bind-case '((0 1 2 3) (10 #(20 30))) 435 311 (((a bs ...) (x (ys zs) ..)) (list a bs x ys zs))) … … 441 317 (let loop ((lst lst) (result '())) 442 318 (bind-case lst 443 (() (reverse result)) 319 (() (reverse result)) ;;;;; 444 320 ((x . xs) 445 321 (loop xs (cons (fn x) result))))))) … … 453 329 (let loop ((vec vec)) 454 330 (bind-case vec 455 (() result) 331 (() result) ;;;;;;; 456 332 ((x . xs) 457 333 (vector-set! result … … 502 378 503 379 (bind-case '((0 1 2 3) (10 #(20 30))) 504 (((_ bs ... c) (_ (ys zs) ..)) (list bs cys zs)))505 '((1 2 ) 3(20) (30))380 (((_ bs ...) (_ (ys zs) ..)) (list bs ys zs))) 381 '((1 2 3) (20) (30)) 506 382 ) 507 383 ;(cases?) 508 384 509 385 (define-checks (lambdas? verbose?) 510 (begin ;; reset internal database511 (bind-listify*)512 ;; add support for vectors and strings513 (bind-listify* vector? vector-car vector-cdr)514 (bind-listify* string? string-car string-cdr)515 #t)516 #t517 386 ((bind-lambda (a (b cs ...) ds ...) 518 387 (list a b cs ds)) 519 388 '(1 #(20 30 40) 2 3)) 520 '(1 20 (30 40) (2 3))389 '(1 20 #(30 40) (2 3)) 521 390 ((bind-lambda (a (b (cs ds) ...) . es) 522 391 (list a b cs ds es)) 523 '(1 #(20 (30 40)) 2 3)) 392 '(1 (20 (30 40)) 2 3)) 393 ;'(1 #(20 (30 40)) 2 3)) 524 394 '(1 20 (30) (40) (2 3)) 525 395 ((bind-lambda (a (b . cs) . ds) … … 591 461 592 462 (define-checks (lets? verbose?) 593 (begin ;; reset internal database594 (bind-listify*)595 ;; add support for vectors and strings596 (bind-listify* vector? vector-car vector-cdr)597 (bind-listify* string? string-car string-cdr)598 #t)599 #t600 463 (bind-let ((((x y) z) '(#(1 2) 3)) 601 464 (u (+ 2 2)) … … 647 510 ;(lets?) 648 511 649 (import biglists)650 ;651 512 (define (integers-from n) 652 513 (Cons n (integers-from (+ n 1)) #f)) 653 514 (define integers (integers-from 0)) 654 (define (Car xs) (At 0 xs)) 655 (define (Cdr xs) (Drop 1 xs)) 515 (define 5integers (Take 5 integers)) 516 (define standard-checkers (sequence-db)) 517 (define checkers 518 ;; add finite lazy list handlers at the front 519 (sequence-db List? 520 Length 521 (lambda (xs k) (At k xs)) 522 (lambda (xs k) (Drop k xs)) 523 List 524 list?)) 656 525 657 526 (define-checks (biglists? verbose?) 658 (begin ;; reset internal database 659 (bind-listify*) 660 ;; add vector and biglist support 661 (bind-listify* vector? vector-car vector-cdr) 662 (bind-listify* BigList? Car Cdr) 663 #t) 664 #t 665 (bind (x y . zs) integers (Car zs)) 527 (if (memq List? standard-checkers) #t #f) 528 #f 529 (if (memq List? checkers) #t #f) 530 #t 531 (car checkers) 532 List? 533 (List? 5integers) 534 #t 535 (bind (x y . zs) 5integers (At 0 zs)) 666 536 2 667 (bind (_ _ . zs) integers (Carzs))537 (bind (_ _ . zs) 5integers (At 0 zs)) 668 538 2 669 539 (bind (x #f (_ (b . cs) . zs)) 670 (vector 1 #f (List 10 integers 2 3))671 (list x b ( Car cs) (Carzs) (At 1 zs)))540 (vector 1 #f (List 10 5integers 2 3)) 541 (list x b (At 0 cs) (At 0 zs) (At 1 zs))) 672 542 '(1 0 1 2 3) 673 543 ) 674 544 ;(biglists?) 675 545 676 (define-checks (dots? verbose?)677 (resolve-dots '(1 2 3) ...)678 '(1 2 3)679 (resolve-dots 1 2 '(30 40) .. 5)680 '(1 2 30 40 5)681 (resolve-dots 1 2 '() .. 5)682 '(1 2 5)683 (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7)684 '(1 20 30 4 40 50 60 7)685 )686 ; (dots?)546 ;(define-checks (dots? verbose?) 547 ; (resolve-dots '(1 2 3) ...) 548 ; '(1 2 3) 549 ; (resolve-dots 1 2 '(30 40) .. 5) 550 ; '(1 2 30 40 5) 551 ; (resolve-dots 1 2 '() .. 5) 552 ; '(1 2 5) 553 ; (resolve-dots 1 '(20 30) ... 4 '(40 50 60) .... 7) 554 ; '(1 20 30 4 40 50 60 7) 555 ;) 556 ;;(dots?) 687 557 688 558 (check-all BINDINGS 689 (listify?)690 (lists-only?)691 559 (defines?) 692 560 (binds?) … … 696 564 (lets?) 697 565 (biglists?) 698 (dots?) 699 ) 700 566 ) 567
Note: See TracChangeset
for help on using the changeset viewer.