1;; 2;; srfi-42 - eager comprehension 3;; 4;; This is a port of Sebastian Egner's reference implementation to Gauche. 5;; Ported by Alex Shinn. 6;; 7 8; <PLAINTEXT> 9; Eager Comprehensions in [outer..inner|expr]-Convention 10; ====================================================== 11; 12; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007 13; Scheme R5RS (incl. macros), SRFI-23 (error). 14; 15; Loading the implementation into Scheme48 0.57: 16; ,open srfi-23 17; ,load ec.scm 18; 19; Loading the implementation into PLT/DrScheme 317: 20; ; File > Open ... "ec.scm", click Execute 21; 22; Loading the implementation into SCM 5d7: 23; (require 'macro) (require 'record) 24; (load "ec.scm") 25; 26; Implementation comments: 27; * All local (not exported) identifiers are named ec-<something>. 28; * This implementation focuses on portability, performance, 29; readability, and simplicity roughly in this order. Design 30; decisions related to performance are taken for Scheme48. 31; * Alternative implementations, Comments and Warnings are 32; mentioned after the definition with a heading. 33 34(define-module srfi-42 35 (use util.match) 36 (use gauche.generator) 37 (export-all)) 38(select-module srfi-42) 39 40(autoload gauche.uvector uvector->list) 41 42;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 43;; 44;; Gauche treats :foo forms as keywords, which are not valid as 45;; identifiers or macros so we can't port this directly. However, all 46;; of the (:keyword ...) forms must be within one of the enclosing *-ec 47;; forms, so we can hack it by making all of those forms replace the 48;; keywords with appropriately renamed identifiers. 49 50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 51;; 52;; The hygienic syntax version. Only replaces top-level qualifiers, so 53;; nested (:keyword ...) forms fail. Recursively replacing them is 54;; possible but much trickier syntax so I haven't gotten around to it 55;; yet. Using this version, the SRFI-42 examples.scm tests fail first 56;; on the following form: 57; 58; (my-check 59; (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x)) 60; => '((1 a) (2 b) (3 c)) ) 61 62; (define-syntax %replace-keywords 63; (syntax-rules () 64; ((_ syn (collect ...)) 65; (syn collect ...)) 66; ((_ syn (collect ...) x y ...) 67; (%replace-one-keyword x syn (collect ...) y ...)))) 68 69; (define-syntax %replace-one-keyword 70; (syntax-rules () 71; ((_ (: x ...) syn (c ...) y ...) 72; (%replace-keywords syn (c ... (srfi-42- x ...)) y ...)) 73; ((_ (:list x ...) syn (c ...) y ...) 74; (%replace-keywords syn (c ... (srfi-42-list x ...)) y ...)) 75; ((_ (:string x ...) syn (c ...) y ...) 76; (%replace-keywords syn (c ... (srfi-42-string x ...)) y ...)) 77; ((_ (:vector x ...) syn (c ...) y ...) 78; (%replace-keywords syn (c ... (srfi-42-vector x ...)) y ...)) 79; ((_ (:integers x ...) syn (c ...) y ...) 80; (%replace-keywords syn (c ... (srfi-42-integers x ...)) y ...)) 81; ((_ (:range x ...) syn (c ...) y ...) 82; (%replace-keywords syn (c ... (srfi-42-range x ...)) y ...)) 83; ((_ (:real-range x ...) syn (c ...) y ...) 84; (%replace-keywords syn (c ... (srfi-42-real-range x ...)) y ...)) 85; ((_ (:char-range x ...) syn (c ...) y ...) 86; (%replace-keywords syn (c ... (srfi-42-char-range x ...)) y ...)) 87; ((_ (:port x ...) syn (c ...) y ...) 88; (%replace-keywords syn (c ... (srfi-42-port x ...)) y ...)) 89; ((_ (:dispatched x ...) syn (c ...) y ...) 90; (%replace-keywords syn (c ... (srfi-42-dispatched x ...)) y ...)) 91; ((_ (:do x ...) syn (c ...) y ...) 92; (%replace-keywords syn (c ... (srfi-42-do x ...)) y ...)) 93; ((_ (:let x ...) syn (c ...) y ...) 94; (%replace-keywords syn (c ... (srfi-42-let x ...)) y ...)) 95; ((_ (:parallel x ...) syn (c ...) y ...) 96; (%replace-keywords syn (c ... (srfi-42-parallel x ...)) y ...)) 97; ((_ (:while x ...) syn (c ...) y ...) 98; (%replace-keywords syn (c ... (srfi-42-while x ...)) y ...)) 99; ((_ (:until x ...) syn (c ...) y ...) 100; (%replace-keywords syn (c ... (srfi-42-until x ...)) y ...)) 101; ((_ x syn (c ...) y ...) (%replace-keywords syn (c ... x) y ...)))) 102 103;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104;; 105;; The low-level macro version. Non-hygienic, so works so long as you 106;; don't try to redefine the meaning of the :qualifiers (which you can't 107;; do in Gauche anyway) or try to use syntax which expands into a 108;; (:qualifier ...) form inside of a *-ec (which would be ugly and poor 109;; style). 110 111;; use the same signature as the hygienic version for compatibility, we 112;; ignore the middle "collector" arg 113(define-macro (%replace-keywords syn _ . args) 114 (define (rename symbol) ; bandage for hygiene 115 ((with-module gauche.internal make-identifier) 116 symbol (current-module) '())) 117 (define (rewrite x) 118 (if (pair? x) 119 (if (keyword? (car x)) 120 (cons 121 (case (car x) 122 ((:) (rename 'srfi-42-)) 123 ((:list) (rename 'srfi-42-list)) 124 ((:string) (rename 'srfi-42-string)) 125 ((:vector) (rename 'srfi-42-vector)) 126 ((:uvector) (rename 'srfi-42-uvector)) 127 ((:integers) (rename 'srfi-42-integers)) 128 ((:range) (rename 'srfi-42-range)) 129 ((:real-range) (rename 'srfi-42-real-range)) 130 ((:char-range) (rename 'srfi-42-char-range)) 131 ((:port) (rename 'srfi-42-port)) 132 ((:generator) (rename 'srfi-42-generator)) 133 ((:collection) (rename 'srfi-42-collection)) 134 ((:dispatched) (rename 'srfi-42-dispatched)) 135 ((:do) (rename 'srfi-42-do)) 136 ((:let) (rename 'srfi-42-let)) 137 ((:parallel) (rename 'srfi-42-parallel)) 138 ((:while) (rename 'srfi-42-while)) 139 ((:until) (rename 'srfi-42-until)) 140 (else (car x))) 141 (rewrite (cdr x))) 142 (cons (rewrite (car x)) (rewrite (cdr x)))) 143 x)) 144 `(,syn ,@(map rewrite args))) 145 146 147; ========================================================================== 148; The fundamental comprehension do-ec 149; ========================================================================== 150; 151; All eager comprehensions are reduced into do-ec and 152; all generators are reduced to :do. 153; 154; We use the following short names for syntactic variables 155; q - qualifier 156; cc - current continuation, thing to call at the end; 157; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...) 158; cmd - an expression being evaluated for its side-effects 159; expr - an expression 160; gen - a generator of an eager comprehension 161; ob - outer binding 162; oc - outer command 163; lb - loop binding 164; ne1? - not-end1? (before the payload) 165; ib - inner binding 166; ic - inner command 167; ne2? - not-end2? (after the payload) 168; ls - loop step 169; etc - more arguments of mixed type 170 171 172; (do-ec q ... cmd) 173; handles nested, if/not/and/or, begin, :let, and calls generator 174; macros in CPS to transform them into fully decorated :do. 175; The code generation for a :do is delegated to do-ec:do. 176 177; (define-syntax do-ec 178; (syntax-rules () 179; ((_ expr ...) 180; (%do-ec (%replace-keywords expr) ...)))) 181 182(define-syntax do-ec 183 (syntax-rules () 184 ((do-ec expr ...) 185 (%replace-keywords %do-ec () expr ...)))) 186 187(define-syntax %do-ec 188 ;;(syntax-rules (nested if not and or begin :do let) 189 (syntax-rules (nested if not and or begin srfi-42-do let) 190 191 ; explicit nesting -> implicit nesting 192 ((do-ec (nested q ...) etc ...) 193 (do-ec q ... etc ...) ) 194 195 ; implicit nesting -> fold do-ec 196 ((do-ec q1 q2 etc1 etc ...) 197 (do-ec q1 (do-ec q2 etc1 etc ...)) ) 198 199 ; no qualifiers at all -> evaluate cmd once 200 ((do-ec cmd) 201 (begin cmd (if #f #f)) ) 202 203; now (do-ec q cmd) remains 204 205 ; filter -> make conditional 206 ((do-ec (if test) cmd) 207 (if test (do-ec cmd)) ) 208 ((do-ec (not test) cmd) 209 (if (not test) (do-ec cmd)) ) 210 ((do-ec (and test ...) cmd) 211 (if (and test ...) (do-ec cmd)) ) 212 ((do-ec (or test ...) cmd) 213 (if (or test ...) (do-ec cmd)) ) 214 215 ; begin -> make a sequence 216 ((do-ec (begin etc ...) cmd) 217 (begin etc ... (do-ec cmd)) ) 218 219 ; fully decorated :do-generator -> delegate to do-ec:do 220 ((do-ec (srfi-42-do olet lbs ne1? ilet ne2? lss) cmd) 221 (do-ec:do cmd (srfi-42-do olet lbs ne1? ilet ne2? lss)) ) 222 223; anything else -> call generator-macro in CPS; reentry at (*) 224 225 ((do-ec (g arg1 arg ...) cmd) 226 (g (do-ec:do cmd) arg1 arg ...) ))) 227 228 229; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss) 230; generates code for a single fully decorated :do-generator 231; with cmd as payload, taking care of special cases. 232 233(define-syntax do-ec:do 234 ;;(syntax-rules (:do let) 235 (syntax-rules (srfi-42-do let) 236 237 ; reentry point (*) -> generate code 238 ((do-ec:do cmd 239 (srfi-42-do (let obs oc ...) 240 lbs 241 ne1? 242 (let ibs ic ...) 243 ne2? 244 (ls ...) )) 245 (ec-simplify 246 (let obs 247 oc ... 248 (let loop lbs 249 (ec-simplify 250 (if ne1? 251 (ec-simplify 252 (let ibs 253 ic ... 254 cmd 255 (ec-simplify 256 (if ne2? 257 (loop ls ...) )))))))))) )) 258 259 260; (ec-simplify <expression>) 261; generates potentially more efficient code for <expression>. 262; The macro handles if, (begin <command>*), and (let () <command>*) 263; and takes care of special cases. 264 265(define-syntax ec-simplify 266 (syntax-rules (if not let begin) 267 268; one- and two-sided if 269 270 ; literal <test> 271 ((ec-simplify (if #t consequent)) 272 consequent ) 273 ((ec-simplify (if #f consequent)) 274 (if #f #f) ) 275 ((ec-simplify (if #t consequent alternate)) 276 consequent ) 277 ((ec-simplify (if #f consequent alternate)) 278 alternate ) 279 280 ; (not (not <test>)) 281 ((ec-simplify (if (not (not test)) consequent)) 282 (ec-simplify (if test consequent)) ) 283 ((ec-simplify (if (not (not test)) consequent alternate)) 284 (ec-simplify (if test consequent alternate)) ) 285 286; (let () <command>*) 287 288 ; empty <binding spec>* 289 ((ec-simplify (let () command ...)) 290 (ec-simplify (begin command ...)) ) 291 292; begin 293 294 ; flatten use helper (ec-simplify 1 done to-do) 295 ((ec-simplify (begin command ...)) 296 (ec-simplify 1 () (command ...)) ) 297 ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...)) 298 (ec-simplify 1 done (to-do1 ... to-do2 ...)) ) 299 ((ec-simplify 1 (done ...) (to-do1 to-do ...)) 300 (ec-simplify 1 (done ... to-do1) (to-do ...)) ) 301 302 ; exit helper 303 ((ec-simplify 1 () ()) 304 (if #f #f) ) 305 ((ec-simplify 1 (command) ()) 306 command ) 307 ((ec-simplify 1 (command1 command ...) ()) 308 (begin command1 command ...) ) 309 310; anything else 311 312 ((ec-simplify expression) 313 expression ))) 314 315 316; ========================================================================== 317; The special generators :do, :let, :parallel, :while, and :until 318; ========================================================================== 319 320(define-syntax srfi-42-do 321 (er-macro-transformer 322 (^[f r c] 323 (match f 324 ;; full decorated -> continue with cc, reentry at (*) 325 [(_ (cc ...) olet lbs ne1? ilet ne2? lss) 326 `(,@cc (,(r'srfi-42-do) ,olet ,lbs ,ne1? ,ilet ,ne2? ,lss))] 327 ;; short form -> fill in default values 328 [(_ cc lbs ne1? lss) 329 (quasirename r 330 `(srfi-42-do ,cc (let ()) ,lbs ,ne1? (let ()) #t ,lss))])))) 331 332(define-syntax srfi-42-let 333 (er-macro-transformer 334 (^[f r c] 335 (define (index.? x) (c (r'index) x)) 336 (match f 337 [(_ cc var ((? index.?) i) expression) 338 (quasirename r 339 `(srfi-42-do ,cc (let ((,var ,expression) (,i 0))) 340 () #t (let ()) #f ()))] 341 [(_ cc var expression) 342 (quasirename r 343 `(srfi-42-do ,cc (let ((,var ,expression))) 344 () #t (let ()) #f ()) )])))) 345 346(define-syntax srfi-42-parallel 347 ;;(syntax-rules (:do) 348 (syntax-rules () 349 ((_ cc) 350 cc ) 351 ((_ cc (g arg1 arg ...) gen ...) 352 (g (srfi-42-parallel-1 cc (gen ...)) arg1 arg ...) ))) 353 354; (:parallel-1 cc (to-do ...) result [ next ] ) 355; iterates over to-do by converting the first generator into 356; the :do-generator next and merging next into result. 357 358(define-syntax srfi-42-parallel-1 ; used as 359 ;;(syntax-rules (:do let) 360 (syntax-rules (srfi-42-do let) 361 362 ; process next element of to-do, reentry at (**) 363 ((_ cc ((g arg1 arg ...) gen ...) result) 364 (g (srfi-42-parallel-1 cc (gen ...) result) arg1 arg ...) ) 365 366 ; reentry point (**) -> merge next into result 367 ((_ 368 cc 369 gens 370 (srfi-42-do (let (ob1 ...) oc1 ...) 371 (lb1 ...) 372 ne1?1 373 (let (ib1 ...) ic1 ...) 374 ne2?1 375 (ls1 ...) ) 376 (srfi-42-do (let (ob2 ...) oc2 ...) 377 (lb2 ...) 378 ne1?2 379 (let (ib2 ...) ic2 ...) 380 ne2?2 381 (ls2 ...) )) 382 (srfi-42-parallel-1 383 cc 384 gens 385 (srfi-42-do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) 386 (lb1 ... lb2 ...) 387 (and ne1?1 ne1?2) 388 (let (ib1 ... ib2 ...) ic1 ... ic2 ...) 389 (and ne2?1 ne2?2) 390 (ls1 ... ls2 ...) ))) 391 392 ; no more gens -> continue with cc, reentry at (*) 393 ((_ (cc ...) () result) 394 (cc ... result) ))) 395 396; (:while-1 cc test (:do ...)) 397; modifies the fully decorated :do-generator such that it 398; runs while test is a true value. 399; The original implementation just replaced ne1? by 400; (and ne1? test) as follows: 401; 402; (define-syntax :while-1 403; (syntax-rules (:do) 404; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss)) 405; (:do cc olet lbs (and ne1? test) ilet ne2? lss) ))) 406; 407; Bug #1: 408; Unfortunately, this code is wrong because ne1? may depend 409; in the inner bindings introduced in ilet, but ne1? is evaluated 410; outside of the inner bindings. (Refer to the specification of 411; :do to see the structure.) 412; The problem manifests itself (as sunnan@handgranat.org 413; observed, 25-Apr-2005) when the :list-generator is modified: 414; 415; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)). 416; 417; In order to generate proper code, we introduce temporary 418; variables saving the values of the inner bindings. The inner 419; bindings are executed in a new ne1?, which also evaluates ne1? 420; outside the scope of the inner bindings, then the inner commands 421; are executed (possibly changing the variables), and then the 422; values of the inner bindings are saved and (and ne1? test) is 423; returned. In the new ilet, the inner variables are bound and 424; initialized and their values are restored. So we construct: 425; 426; (let (ob .. (ib-tmp #f) ...) 427; oc ... 428; (let loop (lb ...) 429; (if (let (ne1?-value ne1?) 430; (let ((ib-var ib-rhs) ...) 431; ic ... 432; (set! ib-tmp ib-var) ...) 433; (and ne1?-value test)) 434; (let ((ib-var ib-tmp) ...) 435; /payload/ 436; (if ne2? 437; (loop ls ...) ))))) 438; 439; Bug #2: 440; Unfortunately, the above expansion is still incorrect (as Jens-Axel 441; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even 442; if ne1?-value is #f, indicating that the loop has ended. 443; The problem manifests itself in the following example: 444; 445; (do-ec (:while (:list x '(1)) #t) (display x)) 446; 447; Which iterates :list beyond exhausting the list '(1). 448; 449; For the fix, we follow Jens-Axel's approach of guarding the evaluation 450; of ib-rhs with a check on ne1?-value. 451 452(define-syntax srfi-42-while 453 (syntax-rules () 454 ((_ cc (g arg1 arg ...) test) 455 (g (srfi-42-while-1 cc test) arg1 arg ...) ))) 456 457(define-syntax srfi-42-while-1 458 (syntax-rules (srfi-42-do let) 459 ((srfi-42-while-1 cc test (srfi-42-do olet lbs ne1? ilet ne2? lss)) 460 (srfi-42-while-2 cc test () () () (srfi-42-do olet lbs ne1? ilet ne2? lss))))) 461 462(define-syntax srfi-42-while-2 463 (syntax-rules (srfi-42-do let) 464 ((srfi-42-while-2 cc 465 test 466 (ib-let ...) 467 (ib-save ...) 468 (ib-restore ...) 469 (srfi-42-do olet 470 lbs 471 ne1? 472 (let ((ib-var ib-rhs) ib ...) ic ...) 473 ne2? 474 lss)) 475 (srfi-42-while-2 cc 476 test 477 (ib-let ... (ib-tmp #f)) 478 (ib-save ... (ib-var ib-rhs)) 479 (ib-restore ... (ib-var ib-tmp)) 480 (srfi-42-do olet 481 lbs 482 ne1? 483 (let (ib ...) ic ... (set! ib-tmp ib-var)) 484 ne2? 485 lss))) 486 ((srfi-42-while-2 cc 487 test 488 (ib-let ...) 489 (ib-save ...) 490 (ib-restore ...) 491 (srfi-42-do (let (ob ...) oc ...) lbs ne1? 492 (let () ic ...) ne2? lss)) 493 (srfi-42-do cc 494 (let (ob ... ib-let ...) oc ...) 495 lbs 496 (let ((ne1?-value ne1?)) 497 (and ne1?-value 498 (let (ib-save ...) 499 ic ... 500 test))) 501 (let (ib-restore ...)) 502 ne2? 503 lss)))) 504 505(define-syntax srfi-42-until 506 (syntax-rules () 507 ((_ cc (g arg1 arg ...) test) 508 (g (srfi-42-until-1 cc test) arg1 arg ...) ))) 509 510(define-syntax srfi-42-until-1 511 ;;(syntax-rules (:do) 512 (syntax-rules (srfi-42-do) 513 ((_ cc test (srfi-42-do olet lbs ne1? ilet ne2? lss)) 514 (srfi-42-do cc olet lbs ne1? ilet (and ne2? (not test)) lss) ))) 515 516 517; ========================================================================== 518; The typed generators :list :string :vector etc. 519; ========================================================================== 520 521(define-syntax srfi-42-list 522 (syntax-rules (index) 523 ((_ cc var (index i) arg ...) 524 (srfi-42-parallel cc (srfi-42-list var arg ...) (srfi-42-integers i)) ) 525 ((_ cc var arg1 arg2 arg ...) 526 (srfi-42-list cc var (append arg1 arg2 arg ...)) ) 527 ((_ cc var arg) 528 (srfi-42-do cc 529 (let ()) 530 ((t arg)) 531 (not (null? t)) 532 (let ((var (car t)))) 533 #t 534 ((cdr t)) )) 535 ((_ x ...) #t))) 536 537 538(define-syntax srfi-42-string 539 (syntax-rules (index) 540 ((_ cc var (index i) arg) 541 (srfi-42-do cc 542 (let ((str arg) (len 0)) 543 (set! len (string-length str))) 544 ((i 0)) 545 (< i len) 546 (let ((var (string-ref str i)))) 547 #t 548 ((+ i 1)) )) 549 ((_ cc var (index i) arg1 arg2 arg ...) 550 (srfi-42-string cc var (index i) (string-append arg1 arg2 arg ...)) ) 551 ((_ cc var arg1 arg ...) 552 (srfi-42-string cc var (index i) arg1 arg ...) ))) 553 554; Alternative: An implementation in the style of :vector can also 555; be used for :string. However, it is less interesting as the 556; overhead of string-append is much less than for 'vector-append'. 557 558(define-syntax srfi-42-vector 559 (syntax-rules () 560 [(_ . args) (srfi-42-*vector vector-length vector-ref . args)])) 561 562(define-syntax srfi-42-uvector 563 (syntax-rules () 564 [(_ . args) (srfi-42-*vector uvector-length uvector-ref . args)])) 565 566(define-syntax srfi-42-*vector 567 (syntax-rules (index) 568 ((_ *len *ref cc var arg) 569 (srfi-42-*vector *len *ref cc var (index i) arg) ) 570 ((_ *len *ref cc var (index i) arg) 571 (srfi-42-do cc 572 (let ((vec arg) (len 0)) 573 (set! len (*len vec))) 574 ((i 0)) 575 (< i len) 576 (let ((var (*ref vec i)))) 577 #t 578 ((+ i 1)) )) 579 580 ((_ *len *ref cc var (index i) arg1 arg2 arg ...) 581 (srfi-42-parallel cc 582 (srfi-42-*vector *len *ref cc var arg1 arg2 arg ...) 583 (srfi-42-integers i)) ) 584 ((_ *len *ref cc var arg1 arg2 arg ...) 585 (srfi-42-do cc 586 (let ((vec #f) 587 (len 0) 588 (vecs (ec-:vector-filter *len (list arg1 arg2 arg ...))) )) 589 ((k 0)) 590 (if (< k len) 591 #t 592 (if (null? vecs) 593 #f 594 (begin (set! vec (car vecs)) 595 (set! vecs (cdr vecs)) 596 (set! len (*len vec)) 597 (set! k 0) 598 #t ))) 599 (let ((var (*ref vec k)))) 600 #t 601 ((+ k 1)) )))) 602 603(define (ec-:vector-filter *len vecs) 604 (if (null? vecs) 605 '() 606 (if (zero? (*len (car vecs))) 607 (ec-:vector-filter *len (cdr vecs)) 608 (cons (car vecs) (ec-:vector-filter *len (cdr vecs))) ))) 609 610; Alternative: A simpler implementation for :vector uses vector->list 611; append and :list in the multi-argument case. Please refer to the 612; 'design.scm' for more details. 613 614 615(define-syntax srfi-42-integers 616 (syntax-rules (index) 617 ((_ cc var (index i)) 618 (srfi-42-do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) ) 619 ((_ cc var) 620 (srfi-42-do cc ((var 0)) #t ((+ var 1))) ))) 621 622 623(define-syntax srfi-42-range 624 (syntax-rules (index) 625 626 ; handle index variable and add optional args 627 ((_ cc var (index i) arg1 arg ...) 628 (srfi-42-parallel cc (srfi-42-range var arg1 arg ...) (srfi-42-integers i)) ) 629 ((_ cc var arg1) 630 (srfi-42-range cc var 0 arg1 1) ) 631 ((_ cc var arg1 arg2) 632 (srfi-42-range cc var arg1 arg2 1) ) 633 634; special cases (partially evaluated by hand from general case) 635 636 ((_ cc var 0 arg2 1) 637 (srfi-42-do cc 638 (let ((b arg2)) 639 (if (not (and (integer? b) (exact? b))) 640 (error 641 "arguments of :range are not exact integer " 642 "(use :real-range?)" 0 b 1 ))) 643 ((var 0)) 644 (< var b) 645 (let ()) 646 #t 647 ((+ var 1)) )) 648 649 ((_ cc var 0 arg2 -1) 650 (srfi-42-do cc 651 (let ((b arg2)) 652 (if (not (and (integer? b) (exact? b))) 653 (error 654 "arguments of :range are not exact integer " 655 "(use :real-range?)" 0 b 1 ))) 656 ((var 0)) 657 (> var b) 658 (let ()) 659 #t 660 ((- var 1)) )) 661 662 ((_ cc var arg1 arg2 1) 663 (srfi-42-do cc 664 (let ((a arg1) (b arg2)) 665 (if (not (and (integer? a) (exact? a) 666 (integer? b) (exact? b) )) 667 (error 668 "arguments of :range are not exact integer " 669 "(use :real-range?)" a b 1 )) ) 670 ((var a)) 671 (< var b) 672 (let ()) 673 #t 674 ((+ var 1)) )) 675 676 ((_ cc var arg1 arg2 -1) 677 (srfi-42-do cc 678 (let ((a arg1) (b arg2) (s -1) (stop 0)) 679 (if (not (and (integer? a) (exact? a) 680 (integer? b) (exact? b) )) 681 (error 682 "arguments of :range are not exact integer " 683 "(use :real-range?)" a b -1 )) ) 684 ((var a)) 685 (> var b) 686 (let ()) 687 #t 688 ((- var 1)) )) 689 690; the general case 691 692 ((_ cc var arg1 arg2 arg3) 693 (srfi-42-do cc 694 (let ((a arg1) (b arg2) (s arg3) (stop 0)) 695 (if (not (and (integer? a) (exact? a) 696 (integer? b) (exact? b) 697 (integer? s) (exact? s) )) 698 (error 699 "arguments of :range are not exact integer " 700 "(use :real-range?)" a b s )) 701 (if (zero? s) 702 (error "step size must not be zero in :range") ) 703 (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s)))) 704 ((var a)) 705 (not (= var stop)) 706 (let ()) 707 #t 708 ((+ var s)) )))) 709 710; Comment: The macro :range inserts some code to make sure the values 711; are exact integers. This overhead has proven very helpful for 712; saving users from themselves. 713 714 715(define-syntax srfi-42-real-range 716 (syntax-rules (index) 717 718 ; add optional args and index variable 719 ((_ cc var arg1) 720 (srfi-42-real-range cc var (index i) 0 arg1 1) ) 721 ((_ cc var (index i) arg1) 722 (srfi-42-real-range cc var (index i) 0 arg1 1) ) 723 ((_ cc var arg1 arg2) 724 (srfi-42-real-range cc var (index i) arg1 arg2 1) ) 725 ((_ cc var (index i) arg1 arg2) 726 (srfi-42-real-range cc var (index i) arg1 arg2 1) ) 727 ((_ cc var arg1 arg2 arg3) 728 (srfi-42-real-range cc var (index i) arg1 arg2 arg3) ) 729 730 ; the fully qualified case 731 ((_ cc var (index i) arg1 arg2 arg3) 732 (srfi-42-do cc 733 (let ((a arg1) (b arg2) (s arg3) (istop 0)) 734 (if (not (and (real? a) (real? b) (real? s))) 735 (error "arguments of :real-range are not real" a b s) ) 736 (if (and (exact? a) (or (not (exact? b)) (not (exact? s)))) 737 (set! a (exact->inexact a)) ) 738 (set! istop (/ (- b a) s)) ) 739 ((i 0)) 740 (< i istop) 741 (let ((var (+ a (* s i))))) 742 #t 743 ((+ i 1)) )))) 744 745; Comment: The macro :real-range adapts the exactness of the start 746; value in case any of the other values is inexact. This is a 747; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0). 748 749 750(define-syntax srfi-42-char-range 751 (syntax-rules (index) 752 ((_ cc var (index i) arg1 arg2) 753 (srfi-42-parallel cc (srfi-42-char-range var arg1 arg2) (srfi-42-integers i)) ) 754 ((_ cc var arg1 arg2) 755 (srfi-42-do cc 756 (let ((imax (char->integer arg2)))) 757 ((i (char->integer arg1))) 758 (<= i imax) 759 (let ((var (integer->char i)))) 760 #t 761 ((+ i 1)) )))) 762 763; Warning: There is no R5RS-way to implement the :char-range generator 764; because the integers obtained by char->integer are not necessarily 765; consecutive. We simply assume this anyhow for illustration. 766 767 768(define-syntax srfi-42-port 769 (syntax-rules (index) 770 [(_ cc var (index i) arg1 arg ...) 771 (srfi-42-parallel cc (srfi-42-port var arg1 arg ...) (srfi-42-integers i))] 772 [(_ cc var arg) 773 (srfi-42-port cc var arg read)] 774 [(_ cc var arg1 arg2) 775 (srfi-42-do cc 776 (let ((port arg1) (read-proc arg2))) 777 ((var (read-proc port))) 778 (not (eof-object? var)) 779 (let ()) 780 #t 781 ((read-proc port)) )])) 782 783;; Gauche extension 784(define-syntax srfi-42-generator 785 (syntax-rules (index) 786 [(_ cc var (index i) expr) 787 (srfi-42-parallel cc (srfi-42-generator var expr) (srfi-42-integers i))] 788 [(_ cc var expr) 789 (srfi-42-do cc 790 (let ([gen expr])) 791 ([var (gen)]) 792 (not (eof-object? var)) 793 (let ()) 794 #t 795 [(gen)])])) 796 797;; Gauche extension 798(define-syntax srfi-42-collection 799 (syntax-rules (index) 800 [(_ cc var (index i) expr) 801 (srfi-42-parallel cc (srfi-42-collection var expr) (srfi-42-integers i))] 802 [(_ cc var expr) 803 (srfi-42-do cc 804 (let ([gen (x->generator expr)])) 805 ([var (gen)]) 806 (not (eof-object? var)) 807 (let ()) 808 #t 809 [(gen)])])) 810 811; ========================================================================== 812; The typed generator :dispatched and utilities for constructing dispatchers 813; ========================================================================== 814 815(define-syntax srfi-42-dispatched 816 (syntax-rules (index) 817 ((_ cc var (index i) dispatch arg1 arg ...) 818 (srfi-42-parallel cc 819 (srfi-42-integers i) 820 (srfi-42-dispatched var dispatch arg1 arg ...) )) 821 ((_ cc var dispatch arg1 arg ...) 822 (srfi-42-do cc 823 (let ((d dispatch) 824 (args (list arg1 arg ...)) 825 (g #f) 826 (empty (list #f)) ) 827 (set! g (d args)) 828 (if (not (procedure? g)) 829 (error "unrecognized arguments in dispatching" 830 args 831 (d '()) ))) 832 ((var (g empty))) 833 (not (eq? var empty)) 834 (let ()) 835 #t 836 ((g empty)) )))) 837 838; Comment: The unique object empty is created as a newly allocated 839; non-empty list. It is compared using eq? which distinguishes 840; the object from any other object, according to R5RS 6.1. 841 842 843(define-syntax srfi-42-generator-proc 844 ;;(syntax-rules (:do let) 845 (syntax-rules (srfi-42-do let) 846 847 ; call g with a variable, reentry at (**) 848 ((_ (g arg ...)) 849 (g (srfi-42-generator-proc var) var arg ...) ) 850 851 ; reentry point (**) -> make the code from a single :do 852 ((_ 853 var 854 (srfi-42-do (let obs oc ...) 855 ((lv li) ...) 856 ne1? 857 (let ((i v) ...) ic ...) 858 ne2? 859 (ls ...)) ) 860 (ec-simplify 861 (let obs 862 oc ... 863 (let ((lv li) ... (ne2 #t)) 864 (ec-simplify 865 (let ((i #f) ...) ; v not yet valid 866 (lambda (empty) 867 (if (and ne1? ne2) 868 (ec-simplify 869 (begin 870 (set! i v) ... 871 ic ... 872 (let ((value var)) 873 (ec-simplify 874 (if ne2? 875 (ec-simplify 876 (begin (set! lv ls) ...) ) 877 (set! ne2 #f) )) 878 value ))) 879 empty )))))))) 880 881 ; silence warnings of some macro expanders 882 ((_ var) 883 (error "illegal macro call") ))) 884 885 886(define (dispatch-union d1 d2) 887 (lambda (args) 888 (let ((g1 (d1 args)) (g2 (d2 args))) 889 (if g1 890 (if g2 891 (if (null? args) 892 (append (if (list? g1) g1 (list g1)) 893 (if (list? g2) g2 (list g2)) ) 894 (error "dispatching conflict" args (d1 '()) (d2 '())) ) 895 g1 ) 896 (if g2 g2 #f) )))) 897 898 899; ========================================================================== 900; The dispatching generator : 901; ========================================================================== 902 903(define (make-initial-:-dispatch) 904 (lambda (args) 905 (case (length args) 906 [(0) 'SRFI42] 907 [(1) (let ([a1 (car args)]) 908 (cond 909 [(list? a1) 910 (srfi-42-generator-proc (srfi-42-list a1))] 911 [(string? a1) 912 (srfi-42-generator-proc (srfi-42-string a1))] 913 [(vector? a1) 914 (srfi-42-generator-proc (srfi-42-vector a1))] 915 [(uvector? a1) 916 (srfi-42-generator-proc (srfi-42-uvector a1))] 917 [(and (integer? a1) (exact? a1)) 918 (srfi-42-generator-proc (srfi-42-range a1))] 919 [(real? a1) 920 (srfi-42-generator-proc (srfi-42-real-range a1))] 921 [(input-port? a1) 922 (srfi-42-generator-proc (srfi-42-port a1))] 923 [(is-a? a1 <collection>) 924 (srfi-42-generator-proc (srfi-42-collection a1))] 925 [(applicable? a1) 926 (srfi-42-generator-proc (srfi-42-generator a1))] 927 [else #f]))] 928 [(2) (let ([a1 (car args)] [a2 (cadr args)]) 929 (cond 930 [(and (list? a1) (list? a2)) 931 (srfi-42-generator-proc (srfi-42-list a1 a2)) ] 932 [(and (string? a1) (string? a1)) 933 (srfi-42-generator-proc (srfi-42-string a1 a2)) ] 934 [(and (vector? a1) (vector? a2)) 935 (srfi-42-generator-proc (srfi-42-vector a1 a2)) ] 936 [(and (uvector? a1) (uvector? a2)) 937 (srfi-42-generator-proc (srfi-42-uvector a1 a2)) ] 938 [(and (integer? a1) (exact? a1) (integer? a2) (exact? a2)) 939 (srfi-42-generator-proc (srfi-42-range a1 a2)) ] 940 [(and (real? a1) (real? a2)) 941 (srfi-42-generator-proc (srfi-42-real-range a1 a2)) ] 942 [(and (char? a1) (char? a2)) 943 (srfi-42-generator-proc (srfi-42-char-range a1 a2)) ] 944 [(and (input-port? a1) (procedure? a2)) 945 (srfi-42-generator-proc (srfi-42-port a1 a2)) ] 946 [else #f]))] 947 [(3) (let ([a1 (car args)] [a2 (cadr args)] [a3 (caddr args)]) 948 (cond 949 [(and (list? a1) (list? a2) (list? a3)) 950 (srfi-42-generator-proc (srfi-42-list a1 a2 a3)) ] 951 [(and (string? a1) (string? a1) (string? a3)) 952 (srfi-42-generator-proc (srfi-42-string a1 a2 a3)) ] 953 [(and (vector? a1) (vector? a2) (vector? a3)) 954 (srfi-42-generator-proc (srfi-42-vector a1 a2 a3)) ] 955 [(and (uvector? a1) (uvector? a2) (uvector? a3)) 956 (srfi-42-generator-proc (srfi-42-uvector a1 a2 a3)) ] 957 [(and (integer? a1) (exact? a1) 958 (integer? a2) (exact? a2) 959 (integer? a3) (exact? a3)) 960 (srfi-42-generator-proc (srfi-42-range a1 a2 a3)) ] 961 [(and (real? a1) (real? a2) (real? a3)) 962 (srfi-42-generator-proc (srfi-42-real-range a1 a2 a3)) ] 963 [else #f]))] 964 [else (cond 965 [(every list? args) 966 (srfi-42-generator-proc (srfi-42-list (apply append args))) ] 967 [(every string? args) 968 (srfi-42-generator-proc (srfi-42-string (apply string-append args)))] 969 [(every vector? args) 970 (srfi-42-generator-proc (srfi-42-vector (apply vector-append args)))] 971 [(every uvector? args) 972 (srfi-42-generator-proc (srfi-42-list (apply append (map uvector->list args))))] 973 [else #f])]))) 974 975(define srfi-42--dispatch 976 (make-initial-:-dispatch) ) 977 978(define (srfi-42--dispatch-ref) 979 srfi-42--dispatch ) 980 981(define (srfi-42--dispatch-set! dispatch) 982 (if (not (procedure? dispatch)) 983 (error "not a procedure" dispatch) ) 984 (set! srfi-42--dispatch dispatch) ) 985 986(define-syntax srfi-42- 987 (syntax-rules (index) 988 ((_ cc var (index i) arg1 arg ...) 989 (srfi-42-dispatched cc var (index i) srfi-42--dispatch arg1 arg ...) ) 990 ((_ cc var arg1 arg ...) 991 (srfi-42-dispatched cc var srfi-42--dispatch arg1 arg ...) ))) 992 993 994; ========================================================================== 995; The utility comprehensions fold-ec, fold3-ec 996; ========================================================================== 997 998(define-syntax fold3-ec 999 (syntax-rules (nested) 1000 ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...) 1001 (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) ) 1002 ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...) 1003 (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) ) 1004 ((fold3-ec x0 expression f1 f2) 1005 (fold3-ec x0 (nested) expression f1 f2) ) 1006 1007 ((fold3-ec x0 qualifier expression f1 f2) 1008 (let ((result #f) (empty #t)) 1009 (do-ec qualifier 1010 (let ((value expression)) ; don't duplicate 1011 (if empty 1012 (begin (set! result (f1 value)) 1013 (set! empty #f) ) 1014 (set! result (f2 value result)) ))) 1015 (if empty x0 result) )))) 1016 1017 1018(define-syntax fold-ec 1019 (syntax-rules (nested) 1020 ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...) 1021 (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) ) 1022 ((fold-ec x0 q1 q2 etc1 etc2 etc ...) 1023 (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) ) 1024 ((fold-ec x0 expression f2) 1025 (fold-ec x0 (nested) expression f2) ) 1026 1027 ((fold-ec x0 qualifier expression f2) 1028 (let ((result x0)) 1029 (do-ec qualifier (set! result (f2 expression result))) 1030 result )))) 1031 1032 1033; ========================================================================== 1034; The comprehensions list-ec string-ec vector-ec etc. 1035; ========================================================================== 1036 1037(define-syntax list-ec 1038 (syntax-rules () 1039 ((list-ec etc1 etc ...) 1040 (reverse (fold-ec '() etc1 etc ... cons)) ))) 1041 1042; Alternative: Reverse can safely be replaced by reverse! if you have it. 1043; 1044; Alternative: It is possible to construct the result in the correct order 1045; using set-cdr! to add at the tail. This removes the overhead of copying 1046; at the end, at the cost of more book-keeping. 1047 1048 1049(define-syntax append-ec 1050 (syntax-rules () 1051 ((append-ec etc1 etc ...) 1052 (apply append (list-ec etc1 etc ...)) ))) 1053 1054(define-syntax string-ec 1055 (syntax-rules () 1056 ((string-ec etc1 etc ...) 1057 (list->string (list-ec etc1 etc ...)) ))) 1058 1059; Alternative: For very long strings, the intermediate list may be a 1060; problem. A more space-aware implementation collect the characters 1061; in an intermediate list and when this list becomes too large it is 1062; converted into an intermediate string. At the end, the intermediate 1063; strings are concatenated with string-append. 1064 1065 1066(define-syntax string-append-ec 1067 (syntax-rules () 1068 ((string-append-ec etc1 etc ...) 1069 (apply string-append (list-ec etc1 etc ...)) ))) 1070 1071(define-syntax vector-ec 1072 (syntax-rules () 1073 ((vector-ec etc1 etc ...) 1074 (list->vector (list-ec etc1 etc ...)) ))) 1075 1076; Comment: A similar approach as for string-ec can be used for vector-ec. 1077; However, the space overhead for the intermediate list is much lower 1078; than for string-ec and as there is no vector-append, the intermediate 1079; vectors must be copied explicitly. 1080 1081(define-syntax vector-of-length-ec 1082 (syntax-rules (nested) 1083 ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...) 1084 (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) ) 1085 ((vector-of-length-ec k q1 q2 etc1 etc ...) 1086 (vector-of-length-ec k (nested q1 q2) etc1 etc ...) ) 1087 ((vector-of-length-ec k expression) 1088 (vector-of-length-ec k (nested) expression) ) 1089 1090 ((vector-of-length-ec k qualifier expression) 1091 (let ((len k)) 1092 (let ((vec (make-vector len)) 1093 (i 0) ) 1094 (do-ec qualifier 1095 (if (< i len) 1096 (begin (vector-set! vec i expression) 1097 (set! i (+ i 1)) ) 1098 (error "vector is too short for the comprehension") )) 1099 (if (= i len) 1100 vec 1101 (error "vector is too long for the comprehension") )))))) 1102 1103 1104(define-syntax sum-ec 1105 (syntax-rules () 1106 ((sum-ec etc1 etc ...) 1107 (fold-ec (+) etc1 etc ... +) ))) 1108 1109(define-syntax product-ec 1110 (syntax-rules () 1111 ((product-ec etc1 etc ...) 1112 (fold-ec (*) etc1 etc ... *) ))) 1113 1114(define-syntax min-ec 1115 (syntax-rules () 1116 ((min-ec etc1 etc ...) 1117 (fold3-ec (min) etc1 etc ... min min) ))) 1118 1119(define-syntax max-ec 1120 (syntax-rules () 1121 ((max-ec etc1 etc ...) 1122 (fold3-ec (max) etc1 etc ... max max) ))) 1123 1124(define-syntax last-ec 1125 (syntax-rules (nested) 1126 ((last-ec default (nested q1 ...) q etc1 etc ...) 1127 (last-ec default (nested q1 ... q) etc1 etc ...) ) 1128 ((last-ec default q1 q2 etc1 etc ...) 1129 (last-ec default (nested q1 q2) etc1 etc ...) ) 1130 ((last-ec default expression) 1131 (last-ec default (nested) expression) ) 1132 1133 ((last-ec default qualifier expression) 1134 (let ((result default)) 1135 (do-ec qualifier (set! result expression)) 1136 result )))) 1137 1138 1139; ========================================================================== 1140; The fundamental early-stopping comprehension first-ec 1141; ========================================================================== 1142 1143(define-syntax first-ec 1144 (syntax-rules () 1145 ((first-ec expr ...) 1146 (%replace-keywords %first-ec () expr ...)))) 1147 1148(define-syntax %first-ec 1149 (syntax-rules (nested) 1150 ((%first-ec default (nested q1 ...) q etc1 etc ...) 1151 (%first-ec default (nested q1 ... q) etc1 etc ...) ) 1152 ((%first-ec default q1 q2 etc1 etc ...) 1153 (%first-ec default (nested q1 q2) etc1 etc ...) ) 1154 ((%first-ec default expression) 1155 (%first-ec default (nested) expression) ) 1156 1157 ((%first-ec default qualifier expression) 1158 (let ((result default) (stop #f)) 1159 (ec-guarded-do-ec 1160 stop 1161 (nested qualifier) 1162 (begin (set! result expression) 1163 (set! stop #t) )) 1164 result )))) 1165 1166; (ec-guarded-do-ec stop (nested q ...) cmd) 1167; constructs (do-ec q ... cmd) where the generators gen in q ... are 1168; replaced by (:until gen stop). 1169 1170(define-syntax ec-guarded-do-ec 1171 (syntax-rules () 1172 ((ec-guarded-do-ec expr ...) 1173 (%replace-keywords %ec-guarded-do-ec () expr ...)))) 1174 1175(define-syntax %ec-guarded-do-ec 1176 (syntax-rules (nested if not and or begin) 1177 1178 ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd) 1179 (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) ) 1180 1181 ((ec-guarded-do-ec stop (nested (if test) q ...) cmd) 1182 (if test (ec-guarded-do-ec stop (nested q ...) cmd)) ) 1183 ((ec-guarded-do-ec stop (nested (not test) q ...) cmd) 1184 (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) ) 1185 ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd) 1186 (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) ) 1187 ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd) 1188 (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) ) 1189 1190 ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd) 1191 (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) ) 1192 1193 ((ec-guarded-do-ec stop (nested gen q ...) cmd) 1194 (do-ec 1195 (srfi-42-until gen stop) 1196 (ec-guarded-do-ec stop (nested q ...) cmd) )) 1197 1198 ((ec-guarded-do-ec stop (nested) cmd) 1199 (do-ec cmd) ))) 1200 1201; Alternative: Instead of modifying the generator with :until, it is 1202; possible to use call-with-current-continuation: 1203; 1204; (define-syntax first-ec 1205; ...same as above... 1206; ((first-ec default qualifier expression) 1207; (call-with-current-continuation 1208; (lambda (cc) 1209; (do-ec qualifier (cc expression)) 1210; default ))) )) 1211; 1212; This is much simpler but not necessarily as efficient. 1213 1214 1215; ========================================================================== 1216; The early-stopping comprehensions any?-ec every?-ec 1217; ========================================================================== 1218 1219(define-syntax any?-ec 1220 (syntax-rules (nested) 1221 ((any?-ec (nested q1 ...) q etc1 etc ...) 1222 (any?-ec (nested q1 ... q) etc1 etc ...) ) 1223 ((any?-ec q1 q2 etc1 etc ...) 1224 (any?-ec (nested q1 q2) etc1 etc ...) ) 1225 ((any?-ec expression) 1226 (any?-ec (nested) expression) ) 1227 1228 ((any?-ec qualifier expression) 1229 (first-ec #f qualifier (if expression) #t) ))) 1230 1231(define-syntax every?-ec 1232 (syntax-rules (nested) 1233 ((every?-ec (nested q1 ...) q etc1 etc ...) 1234 (every?-ec (nested q1 ... q) etc1 etc ...) ) 1235 ((every?-ec q1 q2 etc1 etc ...) 1236 (every?-ec (nested q1 q2) etc1 etc ...) ) 1237 ((every?-ec expression) 1238 (every?-ec (nested) expression) ) 1239 1240 ((every?-ec qualifier expression) 1241 (first-ec #t qualifier (if (not expression)) #f) ))) 1242 1243