Artifact
ef493c9ce19351767b31ac66a3df1690e7f52419:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 29 ;; Copyright (c)
0010: 20 32 30 30 39 20 44 65 72 69 63 6b 20 45 64 64 2009 Derick Edd
0020: 69 6e 67 74 6f 6e 2e 20 20 41 6c 6c 20 72 69 67 ington. All rig
0030: 68 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b hts reserved..;;
0040: 20 4c 69 63 65 6e 73 65 64 20 75 6e 64 65 72 20 Licensed under
0050: 61 6e 20 4d 49 54 2d 73 74 79 6c 65 20 6c 69 63 an MIT-style lic
0060: 65 6e 73 65 2e 20 20 4d 79 20 6c 69 63 65 6e 73 ense. My licens
0070: 65 20 69 73 20 69 6e 20 74 68 65 20 66 69 6c 65 e is in the file
0080: 0a 3b 3b 20 6e 61 6d 65 64 20 4c 49 43 45 4e 53 .;; named LICENS
0090: 45 20 66 72 6f 6d 20 74 68 65 20 6f 72 69 67 69 E from the origi
00a0: 6e 61 6c 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 74 nal collection t
00b0: 68 69 73 20 66 69 6c 65 20 69 73 20 64 69 73 74 his file is dist
00c0: 72 69 62 75 74 65 64 0a 3b 3b 20 77 69 74 68 2e ributed.;; with.
00d0: 20 20 49 66 20 74 68 69 73 20 66 69 6c 65 20 69 If this file i
00e0: 73 20 72 65 64 69 73 74 72 69 62 75 74 65 64 20 s redistributed
00f0: 77 69 74 68 20 73 6f 6d 65 20 6f 74 68 65 72 20 with some other
0100: 63 6f 6c 6c 65 63 74 69 6f 6e 2c 20 6d 79 0a 3b collection, my.;
0110: 3b 20 6c 69 63 65 6e 73 65 20 6d 75 73 74 20 61 ; license must a
0120: 6c 73 6f 20 62 65 20 69 6e 63 6c 75 64 65 64 2e lso be included.
0130: 0a 0a 23 21 72 36 72 73 0a 28 6c 69 62 72 61 72 ..#!r6rs.(librar
0140: 79 20 28 73 72 66 69 20 73 34 32 20 65 61 67 65 y (srfi s42 eage
0150: 72 2d 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 73 r-comprehensions
0160: 29 0a 20 20 28 65 78 70 6f 72 74 0a 20 20 20 20 ). (export.
0170: 64 6f 2d 65 63 20 6c 69 73 74 2d 65 63 20 61 70 do-ec list-ec ap
0180: 70 65 6e 64 2d 65 63 20 73 74 72 69 6e 67 2d 65 pend-ec string-e
0190: 63 20 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 2d c string-append-
01a0: 65 63 20 76 65 63 74 6f 72 2d 65 63 20 0a 20 20 ec vector-ec .
01b0: 20 20 76 65 63 74 6f 72 2d 6f 66 2d 6c 65 6e 67 vector-of-leng
01c0: 74 68 2d 65 63 20 73 75 6d 2d 65 63 20 70 72 6f th-ec sum-ec pro
01d0: 64 75 63 74 2d 65 63 20 6d 69 6e 2d 65 63 20 6d duct-ec min-ec m
01e0: 61 78 2d 65 63 20 61 6e 79 3f 2d 65 63 20 0a 20 ax-ec any?-ec .
01f0: 20 20 20 65 76 65 72 79 3f 2d 65 63 20 66 69 72 every?-ec fir
0200: 73 74 2d 65 63 20 6c 61 73 74 2d 65 63 20 66 6f st-ec last-ec fo
0210: 6c 64 2d 65 63 20 66 6f 6c 64 33 2d 65 63 20 0a ld-ec fold3-ec .
0220: 20 20 20 20 3a 20 3a 6c 69 73 74 20 3a 73 74 72 : :list :str
0230: 69 6e 67 20 3a 76 65 63 74 6f 72 20 3a 69 6e 74 ing :vector :int
0240: 65 67 65 72 73 20 3a 72 61 6e 67 65 20 3a 72 65 egers :range :re
0250: 61 6c 2d 72 61 6e 67 65 20 3a 63 68 61 72 2d 72 al-range :char-r
0260: 61 6e 67 65 20 0a 20 20 20 20 3a 70 6f 72 74 20 ange . :port
0270: 3a 64 69 73 70 61 74 63 68 65 64 20 3a 64 6f 20 :dispatched :do
0280: 3a 6c 65 74 20 3a 70 61 72 61 6c 6c 65 6c 20 3a :let :parallel :
0290: 77 68 69 6c 65 20 3a 75 6e 74 69 6c 0a 20 20 20 while :until.
02a0: 20 3a 2d 64 69 73 70 61 74 63 68 2d 72 65 66 20 :-dispatch-ref
02b0: 3a 2d 64 69 73 70 61 74 63 68 2d 73 65 74 21 20 :-dispatch-set!
02c0: 6d 61 6b 65 2d 69 6e 69 74 69 61 6c 2d 3a 2d 64 make-initial-:-d
02d0: 69 73 70 61 74 63 68 20 0a 20 20 20 20 64 69 73 ispatch . dis
02e0: 70 61 74 63 68 2d 75 6e 69 6f 6e 20 3a 67 65 6e patch-union :gen
02f0: 65 72 61 74 6f 72 2d 70 72 6f 63 29 0a 20 20 28 erator-proc). (
0300: 69 6d 70 6f 72 74 0a 20 20 20 20 28 72 6e 72 73 import. (rnrs
0310: 29 0a 20 20 20 20 28 72 6e 72 73 20 72 35 72 73 ). (rnrs r5rs
0320: 29 0a 20 20 20 20 28 73 72 66 69 20 73 33 39 20 ). (srfi s39
0330: 70 61 72 61 6d 65 74 65 72 73 29 0a 20 20 20 20 parameters).
0340: 28 73 72 66 69 20 73 32 33 20 65 72 72 6f 72 20 (srfi s23 error
0350: 74 72 69 63 6b 73 29 0a 20 20 20 20 28 73 72 66 tricks). (srf
0360: 69 20 70 72 69 76 61 74 65 20 69 6e 63 6c 75 64 i private includ
0370: 65 29 29 0a 20 20 0a 20 20 3b 3b 20 28 53 52 46 e)). . ;; (SRF
0380: 49 2d 32 33 2d 65 72 72 6f 72 2d 3e 52 36 52 53 I-23-error->R6RS
0390: 20 22 28 6c 69 62 72 61 72 79 20 28 73 72 66 69 "(library (srfi
03a0: 20 73 34 32 20 65 61 67 65 72 2d 63 6f 6d 70 72 s42 eager-compr
03b0: 65 68 65 6e 73 69 6f 6e 73 29 29 22 0a 20 20 3b ehensions))". ;
03c0: 3b 20 20 28 69 6e 63 6c 75 64 65 2f 72 65 73 6f ; (include/reso
03d0: 6c 76 65 20 28 22 73 72 66 69 22 20 22 25 33 61 lve ("srfi" "%3a
03e0: 34 32 22 29 20 22 65 63 2e 73 63 6d 22 29 29 0a 42") "ec.scm")).
03f0: 0a 3b 20 3c 50 4c 41 49 4e 54 45 58 54 3e 0a 3b .; <PLAINTEXT>.;
0400: 20 45 61 67 65 72 20 43 6f 6d 70 72 65 68 65 6e Eager Comprehen
0410: 73 69 6f 6e 73 20 69 6e 20 5b 6f 75 74 65 72 2e sions in [outer.
0420: 2e 69 6e 6e 65 72 7c 65 78 70 72 5d 2d 43 6f 6e .inner|expr]-Con
0430: 76 65 6e 74 69 6f 6e 0a 3b 20 3d 3d 3d 3d 3d 3d vention.; ======
0440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 0a 3b 0a 3b 20 73 65 62 61 73 74 69 61 6e 2e 65 .;.; sebastian.e
0480: 67 6e 65 72 40 70 68 69 6c 69 70 73 2e 63 6f 6d gner@philips.com
0490: 2c 20 45 69 6e 64 68 6f 76 65 6e 2c 20 54 68 65 , Eindhoven, The
04a0: 20 4e 65 74 68 65 72 6c 61 6e 64 73 2c 20 32 35 Netherlands, 25
04b0: 2d 41 70 72 2d 32 30 30 35 0a 3b 20 53 63 68 65 -Apr-2005.; Sche
04c0: 6d 65 20 52 35 52 53 20 28 69 6e 63 6c 2e 20 6d me R5RS (incl. m
04d0: 61 63 72 6f 73 29 2c 20 53 52 46 49 2d 32 33 20 acros), SRFI-23
04e0: 28 65 72 72 6f 72 29 2e 0a 3b 0a 3b 20 4d 6f 64 (error)..;.; Mod
04f0: 69 66 69 65 64 20 62 79 20 44 65 72 69 63 6b 20 ified by Derick
0500: 45 64 64 69 6e 67 74 6f 6e 20 74 6f 20 62 65 20 Eddington to be
0510: 61 62 6c 65 20 74 6f 20 62 65 20 69 6e 63 6c 75 able to be inclu
0520: 64 65 64 20 69 6e 74 6f 20 61 6e 20 52 36 52 53 ded into an R6RS
0530: 20 6c 69 62 72 61 72 79 2e 0a 3b 20 0a 3b 20 4c library..; .; L
0540: 6f 61 64 69 6e 67 20 74 68 65 20 69 6d 70 6c 65 oading the imple
0550: 6d 65 6e 74 61 74 69 6f 6e 20 69 6e 74 6f 20 53 mentation into S
0560: 63 68 65 6d 65 34 38 20 30 2e 35 37 3a 0a 3b 20 cheme48 0.57:.;
0570: 20 20 2c 6f 70 65 6e 20 73 72 66 69 2d 32 33 0a ,open srfi-23.
0580: 3b 20 20 20 2c 6c 6f 61 64 20 65 63 2e 73 63 6d ; ,load ec.scm
0590: 0a 3b 0a 3b 20 4c 6f 61 64 69 6e 67 20 74 68 65 .;.; Loading the
05a0: 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 implementation
05b0: 69 6e 74 6f 20 50 4c 54 2f 44 72 53 63 68 65 6d into PLT/DrSchem
05c0: 65 20 32 30 32 3a 0a 3b 20 20 20 3b 20 46 69 6c e 202:.; ; Fil
05d0: 65 20 3e 20 4f 70 65 6e 20 2e 2e 2e 20 22 65 63 e > Open ... "ec
05e0: 2e 73 63 6d 22 2c 20 63 6c 69 63 6b 20 45 78 65 .scm", click Exe
05f0: 63 75 74 65 0a 3b 0a 3b 20 4c 6f 61 64 69 6e 67 cute.;.; Loading
0600: 20 74 68 65 20 69 6d 70 6c 65 6d 65 6e 74 61 74 the implementat
0610: 69 6f 6e 20 69 6e 74 6f 20 53 43 4d 20 35 64 37 ion into SCM 5d7
0620: 3a 0a 3b 20 20 20 28 72 65 71 75 69 72 65 20 27 :.; (require '
0630: 6d 61 63 72 6f 29 20 28 72 65 71 75 69 72 65 20 macro) (require
0640: 27 72 65 63 6f 72 64 29 20 0a 3b 20 20 20 28 6c 'record) .; (l
0650: 6f 61 64 20 22 65 63 2e 73 63 6d 22 29 0a 3b 0a oad "ec.scm").;.
0660: 3b 20 49 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e ; Implementation
0670: 20 63 6f 6d 6d 65 6e 74 73 3a 0a 3b 20 20 20 2a comments:.; *
0680: 20 41 6c 6c 20 6c 6f 63 61 6c 20 28 6e 6f 74 20 All local (not
0690: 65 78 70 6f 72 74 65 64 29 20 69 64 65 6e 74 69 exported) identi
06a0: 66 69 65 72 73 20 61 72 65 20 6e 61 6d 65 64 20 fiers are named
06b0: 65 63 2d 3c 73 6f 6d 65 74 68 69 6e 67 3e 2e 0a ec-<something>..
06c0: 3b 20 20 20 2a 20 54 68 69 73 20 69 6d 70 6c 65 ; * This imple
06d0: 6d 65 6e 74 61 74 69 6f 6e 20 66 6f 63 75 73 65 mentation focuse
06e0: 73 20 6f 6e 20 70 6f 72 74 61 62 69 6c 69 74 79 s on portability
06f0: 2c 20 70 65 72 66 6f 72 6d 61 6e 63 65 2c 20 0a , performance, .
0700: 3b 20 20 20 20 20 72 65 61 64 61 62 69 6c 69 74 ; readabilit
0710: 79 2c 20 61 6e 64 20 73 69 6d 70 6c 69 63 69 74 y, and simplicit
0720: 79 20 72 6f 75 67 68 6c 79 20 69 6e 20 74 68 69 y roughly in thi
0730: 73 20 6f 72 64 65 72 2e 20 44 65 73 69 67 6e 0a s order. Design.
0740: 3b 20 20 20 20 20 64 65 63 69 73 69 6f 6e 73 20 ; decisions
0750: 72 65 6c 61 74 65 64 20 74 6f 20 70 65 72 66 6f related to perfo
0760: 72 6d 61 6e 63 65 20 61 72 65 20 74 61 6b 65 6e rmance are taken
0770: 20 66 6f 72 20 53 63 68 65 6d 65 34 38 2e 0a 3b for Scheme48..;
0780: 20 20 20 2a 20 41 6c 74 65 72 6e 61 74 69 76 65 * Alternative
0790: 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 73 implementations
07a0: 2c 20 43 6f 6d 6d 65 6e 74 73 20 61 6e 64 20 57 , Comments and W
07b0: 61 72 6e 69 6e 67 73 20 61 72 65 20 0a 3b 20 20 arnings are .;
07c0: 20 20 20 6d 65 6e 74 69 6f 6e 65 64 20 61 66 74 mentioned aft
07d0: 65 72 20 74 68 65 20 64 65 66 69 6e 69 74 69 6f er the definitio
07e0: 6e 20 77 69 74 68 20 61 20 68 65 61 64 69 6e 67 n with a heading
07f0: 2e 0a 0a 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ....; ==========
0800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0840: 0a 3b 20 54 68 65 20 66 75 6e 64 61 6d 65 6e 74 .; The fundament
0850: 61 6c 20 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e al comprehension
0860: 20 64 6f 2d 65 63 0a 3b 20 3d 3d 3d 3d 3d 3d 3d do-ec.; =======
0870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 0a 3b 0a 3b 20 41 6c 6c 20 65 61 67 65 ===.;.; All eage
08c0: 72 20 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 73 r comprehensions
08d0: 20 61 72 65 20 72 65 64 75 63 65 64 20 69 6e 74 are reduced int
08e0: 6f 20 64 6f 2d 65 63 20 61 6e 64 0a 3b 20 61 6c o do-ec and.; al
08f0: 6c 20 67 65 6e 65 72 61 74 6f 72 73 20 61 72 65 l generators are
0900: 20 72 65 64 75 63 65 64 20 74 6f 20 3a 64 6f 2e reduced to :do.
0910: 20 0a 3b 0a 3b 20 57 65 20 75 73 65 20 74 68 65 .;.; We use the
0920: 20 66 6f 6c 6c 6f 77 69 6e 67 20 73 68 6f 72 74 following short
0930: 20 6e 61 6d 65 73 20 66 6f 72 20 73 79 6e 74 61 names for synta
0940: 63 74 69 63 20 76 61 72 69 61 62 6c 65 73 0a 3b ctic variables.;
0950: 20 20 20 71 20 20 20 20 2d 20 71 75 61 6c 69 66 q - qualif
0960: 69 65 72 0a 3b 20 20 20 63 63 20 20 20 2d 20 63 ier.; cc - c
0970: 75 72 72 65 6e 74 20 63 6f 6e 74 69 6e 75 61 74 urrent continuat
0980: 69 6f 6e 2c 20 74 68 69 6e 67 20 74 6f 20 63 61 ion, thing to ca
0990: 6c 6c 20 61 74 20 74 68 65 20 65 6e 64 3b 0a 3b ll at the end;.;
09a0: 20 20 20 20 20 20 20 20 20 20 74 68 65 20 43 50 the CP
09b0: 53 20 69 73 20 28 6d 20 28 63 63 20 2e 2e 2e 29 S is (m (cc ...)
09c0: 20 61 72 67 20 2e 2e 2e 29 20 2d 3e 20 28 63 63 arg ...) -> (cc
09d0: 20 2e 2e 2e 20 65 78 70 72 20 2e 2e 2e 29 0a 3b ... expr ...).;
09e0: 20 20 20 63 6d 64 20 20 2d 20 61 6e 20 65 78 70 cmd - an exp
09f0: 72 65 73 73 69 6f 6e 20 62 65 69 6e 67 20 65 76 ression being ev
0a00: 61 6c 75 61 74 65 64 20 66 6f 72 20 69 74 73 20 aluated for its
0a10: 73 69 64 65 2d 65 66 66 65 63 74 73 0a 3b 20 20 side-effects.;
0a20: 20 65 78 70 72 20 2d 20 61 6e 20 65 78 70 72 65 expr - an expre
0a30: 73 73 69 6f 6e 0a 3b 20 20 20 67 65 6e 20 20 2d ssion.; gen -
0a40: 20 61 20 67 65 6e 65 72 61 74 6f 72 20 6f 66 20 a generator of
0a50: 61 6e 20 65 61 67 65 72 20 63 6f 6d 70 72 65 68 an eager compreh
0a60: 65 6e 73 69 6f 6e 0a 3b 20 20 20 6f 62 20 20 20 ension.; ob
0a70: 2d 20 6f 75 74 65 72 20 62 69 6e 64 69 6e 67 0a - outer binding.
0a80: 3b 20 20 20 6f 63 20 20 20 2d 20 6f 75 74 65 72 ; oc - outer
0a90: 20 63 6f 6d 6d 61 6e 64 0a 3b 20 20 20 6c 62 20 command.; lb
0aa0: 20 20 2d 20 6c 6f 6f 70 20 62 69 6e 64 69 6e 67 - loop binding
0ab0: 0a 3b 20 20 20 6e 65 31 3f 20 2d 20 6e 6f 74 2d .; ne1? - not-
0ac0: 65 6e 64 31 3f 20 28 62 65 66 6f 72 65 20 74 68 end1? (before th
0ad0: 65 20 70 61 79 6c 6f 61 64 29 0a 3b 20 20 20 69 e payload).; i
0ae0: 62 20 20 20 2d 20 69 6e 6e 65 72 20 62 69 6e 64 b - inner bind
0af0: 69 6e 67 0a 3b 20 20 20 69 63 20 20 20 2d 20 69 ing.; ic - i
0b00: 6e 6e 65 72 20 63 6f 6d 6d 61 6e 64 0a 3b 20 20 nner command.;
0b10: 20 6e 65 32 3f 20 2d 20 6e 6f 74 2d 65 6e 64 32 ne2? - not-end2
0b20: 3f 20 28 61 66 74 65 72 20 74 68 65 20 70 61 79 ? (after the pay
0b30: 6c 6f 61 64 29 0a 3b 20 20 20 6c 73 20 20 20 2d load).; ls -
0b40: 20 6c 6f 6f 70 20 73 74 65 70 0a 3b 20 20 20 65 loop step.; e
0b50: 74 63 20 20 2d 20 6d 6f 72 65 20 61 72 67 75 6d tc - more argum
0b60: 65 6e 74 73 20 6f 66 20 6d 69 78 65 64 20 74 79 ents of mixed ty
0b70: 70 65 0a 0a 0a 3b 20 28 64 6f 2d 65 63 20 71 20 pe...; (do-ec q
0b80: 2e 2e 2e 20 63 6d 64 29 0a 3b 20 20 20 68 61 6e ... cmd).; han
0b90: 64 6c 65 73 20 6e 65 73 74 65 64 2c 20 69 66 2f dles nested, if/
0ba0: 6e 6f 74 2f 61 6e 64 2f 6f 72 2c 20 62 65 67 69 not/and/or, begi
0bb0: 6e 2c 20 3a 6c 65 74 2c 20 61 6e 64 20 63 61 6c n, :let, and cal
0bc0: 6c 73 20 67 65 6e 65 72 61 74 6f 72 20 0a 3b 20 ls generator .;
0bd0: 20 20 6d 61 63 72 6f 73 20 69 6e 20 43 50 53 20 macros in CPS
0be0: 74 6f 20 74 72 61 6e 73 66 6f 72 6d 20 74 68 65 to transform the
0bf0: 6d 20 69 6e 74 6f 20 66 75 6c 6c 79 20 64 65 63 m into fully dec
0c00: 6f 72 61 74 65 64 20 3a 64 6f 2e 0a 3b 20 20 20 orated :do..;
0c10: 54 68 65 20 63 6f 64 65 20 67 65 6e 65 72 61 74 The code generat
0c20: 69 6f 6e 20 66 6f 72 20 61 20 3a 64 6f 20 69 73 ion for a :do is
0c30: 20 64 65 6c 65 67 61 74 65 64 20 74 6f 20 64 6f delegated to do
0c40: 2d 65 63 3a 64 6f 2e 0a 0a 28 64 65 66 69 6e 65 -ec:do...(define
0c50: 2d 73 79 6e 74 61 78 20 64 6f 2d 65 63 0a 20 20 -syntax do-ec.
0c60: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 6e (syntax-rules (n
0c70: 65 73 74 65 64 20 69 66 20 6e 6f 74 20 61 6e 64 ested if not and
0c80: 20 6f 72 20 62 65 67 69 6e 20 3a 64 6f 20 6c 65 or begin :do le
0c90: 74 29 0a 0a 20 20 20 20 3b 20 65 78 70 6c 69 63 t).. ; explic
0ca0: 69 74 20 6e 65 73 74 69 6e 67 20 2d 3e 20 69 6d it nesting -> im
0cb0: 70 6c 69 63 69 74 20 6e 65 73 74 69 6e 67 0a 20 plicit nesting.
0cc0: 20 20 20 28 28 64 6f 2d 65 63 20 28 6e 65 73 74 ((do-ec (nest
0cd0: 65 64 20 71 20 2e 2e 2e 29 20 65 74 63 20 2e 2e ed q ...) etc ..
0ce0: 2e 29 0a 20 20 20 20 20 28 64 6f 2d 65 63 20 71 .). (do-ec q
0cf0: 20 2e 2e 2e 20 65 74 63 20 2e 2e 2e 29 20 29 0a ... etc ...) ).
0d00: 0a 20 20 20 20 3b 20 69 6d 70 6c 69 63 69 74 20 . ; implicit
0d10: 6e 65 73 74 69 6e 67 20 2d 3e 20 66 6f 6c 64 20 nesting -> fold
0d20: 64 6f 2d 65 63 0a 20 20 20 20 28 28 64 6f 2d 65 do-ec. ((do-e
0d30: 63 20 71 31 20 71 32 20 65 74 63 31 20 65 74 63 c q1 q2 etc1 etc
0d40: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 64 6f 2d 65 ...). (do-e
0d50: 63 20 71 31 20 28 64 6f 2d 65 63 20 71 32 20 65 c q1 (do-ec q2 e
0d60: 74 63 31 20 65 74 63 20 2e 2e 2e 29 29 20 29 0a tc1 etc ...)) ).
0d70: 0a 20 20 20 20 3b 20 6e 6f 20 71 75 61 6c 69 66 . ; no qualif
0d80: 69 65 72 73 20 61 74 20 61 6c 6c 20 2d 3e 20 65 iers at all -> e
0d90: 76 61 6c 75 61 74 65 20 63 6d 64 20 6f 6e 63 65 valuate cmd once
0da0: 0a 20 20 20 20 28 28 64 6f 2d 65 63 20 63 6d 64 . ((do-ec cmd
0db0: 29 0a 20 20 20 20 20 28 62 65 67 69 6e 20 63 6d ). (begin cm
0dc0: 64 20 28 69 66 20 23 66 20 23 66 29 29 20 29 0a d (if #f #f)) ).
0dd0: 0a 3b 20 6e 6f 77 20 28 64 6f 2d 65 63 20 71 20 .; now (do-ec q
0de0: 63 6d 64 29 20 72 65 6d 61 69 6e 73 0a 0a 20 20 cmd) remains..
0df0: 20 20 3b 20 66 69 6c 74 65 72 20 2d 3e 20 6d 61 ; filter -> ma
0e00: 6b 65 20 63 6f 6e 64 69 74 69 6f 6e 61 6c 0a 20 ke conditional.
0e10: 20 20 20 28 28 64 6f 2d 65 63 20 28 69 66 20 74 ((do-ec (if t
0e20: 65 73 74 29 20 63 6d 64 29 0a 20 20 20 20 20 28 est) cmd). (
0e30: 69 66 20 74 65 73 74 20 28 64 6f 2d 65 63 20 63 if test (do-ec c
0e40: 6d 64 29 29 20 29 0a 20 20 20 20 28 28 64 6f 2d md)) ). ((do-
0e50: 65 63 20 28 6e 6f 74 20 74 65 73 74 29 20 63 6d ec (not test) cm
0e60: 64 29 0a 20 20 20 20 20 28 69 66 20 28 6e 6f 74 d). (if (not
0e70: 20 74 65 73 74 29 20 28 64 6f 2d 65 63 20 63 6d test) (do-ec cm
0e80: 64 29 29 20 29 0a 20 20 20 20 28 28 64 6f 2d 65 d)) ). ((do-e
0e90: 63 20 28 61 6e 64 20 74 65 73 74 20 2e 2e 2e 29 c (and test ...)
0ea0: 20 63 6d 64 29 0a 20 20 20 20 20 28 69 66 20 28 cmd). (if (
0eb0: 61 6e 64 20 74 65 73 74 20 2e 2e 2e 29 20 28 64 and test ...) (d
0ec0: 6f 2d 65 63 20 63 6d 64 29 29 20 29 0a 20 20 20 o-ec cmd)) ).
0ed0: 20 28 28 64 6f 2d 65 63 20 28 6f 72 20 74 65 73 ((do-ec (or tes
0ee0: 74 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 t ...) cmd).
0ef0: 20 28 69 66 20 28 6f 72 20 74 65 73 74 20 2e 2e (if (or test ..
0f00: 2e 29 20 28 64 6f 2d 65 63 20 63 6d 64 29 29 20 .) (do-ec cmd))
0f10: 29 0a 0a 20 20 20 20 3b 20 62 65 67 69 6e 20 2d ).. ; begin -
0f20: 3e 20 6d 61 6b 65 20 61 20 73 65 71 75 65 6e 63 > make a sequenc
0f30: 65 0a 20 20 20 20 28 28 64 6f 2d 65 63 20 28 62 e. ((do-ec (b
0f40: 65 67 69 6e 20 65 74 63 20 2e 2e 2e 29 20 63 6d egin etc ...) cm
0f50: 64 29 0a 20 20 20 20 20 28 62 65 67 69 6e 20 65 d). (begin e
0f60: 74 63 20 2e 2e 2e 20 28 64 6f 2d 65 63 20 63 6d tc ... (do-ec cm
0f70: 64 29 29 20 29 0a 0a 20 20 20 20 3b 20 66 75 6c d)) ).. ; ful
0f80: 6c 79 20 64 65 63 6f 72 61 74 65 64 20 3a 64 6f ly decorated :do
0f90: 2d 67 65 6e 65 72 61 74 6f 72 20 2d 3e 20 64 65 -generator -> de
0fa0: 6c 65 67 61 74 65 20 74 6f 20 64 6f 2d 65 63 3a legate to do-ec:
0fb0: 64 6f 0a 20 20 20 20 28 28 64 6f 2d 65 63 20 28 do. ((do-ec (
0fc0: 3a 64 6f 20 6f 6c 65 74 20 6c 62 73 20 6e 65 31 :do olet lbs ne1
0fd0: 3f 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 73 29 ? ilet ne2? lss)
0fe0: 20 63 6d 64 29 0a 20 20 20 20 20 28 64 6f 2d 65 cmd). (do-e
0ff0: 63 3a 64 6f 20 63 6d 64 20 28 3a 64 6f 20 6f 6c c:do cmd (:do ol
1000: 65 74 20 6c 62 73 20 6e 65 31 3f 20 69 6c 65 74 et lbs ne1? ilet
1010: 20 6e 65 32 3f 20 6c 73 73 29 29 20 29 0a 0a 3b ne2? lss)) )..;
1020: 20 61 6e 79 74 68 69 6e 67 20 65 6c 73 65 20 2d anything else -
1030: 3e 20 63 61 6c 6c 20 67 65 6e 65 72 61 74 6f 72 > call generator
1040: 2d 6d 61 63 72 6f 20 69 6e 20 43 50 53 3b 20 72 -macro in CPS; r
1050: 65 65 6e 74 72 79 20 61 74 20 28 2a 29 0a 0a 20 eentry at (*)..
1060: 20 20 20 28 28 64 6f 2d 65 63 20 28 67 20 61 72 ((do-ec (g ar
1070: 67 31 20 61 72 67 20 2e 2e 2e 29 20 63 6d 64 29 g1 arg ...) cmd)
1080: 0a 20 20 20 20 20 28 67 20 28 64 6f 2d 65 63 3a . (g (do-ec:
1090: 64 6f 20 63 6d 64 29 20 61 72 67 31 20 61 72 67 do cmd) arg1 arg
10a0: 20 2e 2e 2e 29 20 29 29 29 0a 0a 0a 3b 20 28 64 ...) )))...; (d
10b0: 6f 2d 65 63 3a 64 6f 20 63 6d 64 20 28 3a 64 6f o-ec:do cmd (:do
10c0: 20 6f 6c 65 74 20 6c 62 73 20 6e 65 31 3f 20 69 olet lbs ne1? i
10d0: 6c 65 74 20 6e 65 32 3f 20 6c 73 73 29 29 0a 3b let ne2? lss)).;
10e0: 20 20 20 67 65 6e 65 72 61 74 65 73 20 63 6f 64 generates cod
10f0: 65 20 66 6f 72 20 61 20 73 69 6e 67 6c 65 20 66 e for a single f
1100: 75 6c 6c 79 20 64 65 63 6f 72 61 74 65 64 20 3a ully decorated :
1110: 64 6f 2d 67 65 6e 65 72 61 74 6f 72 0a 3b 20 20 do-generator.;
1120: 20 77 69 74 68 20 63 6d 64 20 61 73 20 70 61 79 with cmd as pay
1130: 6c 6f 61 64 2c 20 74 61 6b 69 6e 67 20 63 61 72 load, taking car
1140: 65 20 6f 66 20 73 70 65 63 69 61 6c 20 63 61 73 e of special cas
1150: 65 73 2e 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e es...(define-syn
1160: 74 61 78 20 64 6f 2d 65 63 3a 64 6f 0a 20 20 28 tax do-ec:do. (
1170: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 3a 64 syntax-rules (:d
1180: 6f 20 6c 65 74 29 0a 0a 20 20 20 20 3b 20 72 65 o let).. ; re
1190: 65 6e 74 72 79 20 70 6f 69 6e 74 20 28 2a 29 20 entry point (*)
11a0: 2d 3e 20 67 65 6e 65 72 61 74 65 20 63 6f 64 65 -> generate code
11b0: 0a 20 20 20 20 28 28 64 6f 2d 65 63 3a 64 6f 20 . ((do-ec:do
11c0: 63 6d 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 cmd .
11d0: 20 20 20 20 28 3a 64 6f 20 28 6c 65 74 20 6f 62 (:do (let ob
11e0: 73 20 6f 63 20 2e 2e 2e 29 20 0a 20 20 20 20 20 s oc ...) .
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6c l
1200: 62 73 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 bs .
1210: 20 20 20 20 20 20 20 20 6e 65 31 3f 20 0a 20 20 ne1? .
1220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1230: 20 20 28 6c 65 74 20 69 62 73 20 69 63 20 2e 2e (let ibs ic ..
1240: 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .) .
1250: 20 20 20 20 20 20 20 20 6e 65 32 3f 20 0a 20 20 ne2? .
1260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1270: 20 20 28 6c 73 20 2e 2e 2e 29 20 29 29 0a 20 20 (ls ...) )).
1280: 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 0a (ec-simplify.
1290: 20 20 20 20 20 20 20 28 6c 65 74 20 6f 62 73 0a (let obs.
12a0: 20 20 20 20 20 20 20 20 20 6f 63 20 2e 2e 2e 0a oc ....
12b0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f (let lo
12c0: 6f 70 20 6c 62 73 0a 20 20 20 20 20 20 20 20 20 op lbs.
12d0: 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 0a 20 (ec-simplify.
12e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
12f0: 6e 65 31 3f 0a 20 20 20 20 20 20 20 20 20 20 20 ne1?.
1300: 20 20 20 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 (ec-simpli
1310: 66 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 fy.
1320: 20 20 20 20 20 20 28 6c 65 74 20 69 62 73 0a 20 (let ibs.
1330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1340: 20 20 20 20 20 69 63 20 2e 2e 2e 0a 20 20 20 20 ic ....
1350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1360: 20 20 63 6d 64 0a 20 20 20 20 20 20 20 20 20 20 cmd.
1370: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 63 2d (ec-
1380: 73 69 6d 70 6c 69 66 79 0a 20 20 20 20 20 20 20 simplify.
1390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13a0: 20 28 69 66 20 6e 65 32 3f 0a 20 20 20 20 20 20 (if ne2?.
13b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13c0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 6c 73 20 2e (loop ls .
13d0: 2e 2e 29 20 29 29 29 29 29 29 29 29 29 29 20 29 ..) )))))))))) )
13e0: 29 0a 0a 20 20 20 20 0a 3b 20 28 65 63 2d 73 69 ).. .; (ec-si
13f0: 6d 70 6c 69 66 79 20 3c 65 78 70 72 65 73 73 69 mplify <expressi
1400: 6f 6e 3e 29 0a 3b 20 20 20 67 65 6e 65 72 61 74 on>).; generat
1410: 65 73 20 70 6f 74 65 6e 74 69 61 6c 6c 79 20 6d es potentially m
1420: 6f 72 65 20 65 66 66 69 63 69 65 6e 74 20 63 6f ore efficient co
1430: 64 65 20 66 6f 72 20 3c 65 78 70 72 65 73 73 69 de for <expressi
1440: 6f 6e 3e 2e 0a 3b 20 20 20 54 68 65 20 6d 61 63 on>..; The mac
1450: 72 6f 20 68 61 6e 64 6c 65 73 20 69 66 2c 20 28 ro handles if, (
1460: 62 65 67 69 6e 20 3c 63 6f 6d 6d 61 6e 64 3e 2a begin <command>*
1470: 29 2c 20 61 6e 64 20 28 6c 65 74 20 28 29 20 3c ), and (let () <
1480: 63 6f 6d 6d 61 6e 64 3e 2a 29 0a 3b 20 20 20 61 command>*).; a
1490: 6e 64 20 74 61 6b 65 73 20 63 61 72 65 20 6f 66 nd takes care of
14a0: 20 73 70 65 63 69 61 6c 20 63 61 73 65 73 2e 0a special cases..
14b0: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax
14c0: 65 63 2d 73 69 6d 70 6c 69 66 79 0a 20 20 28 73 ec-simplify. (s
14d0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 66 20 yntax-rules (if
14e0: 6e 6f 74 20 6c 65 74 20 62 65 67 69 6e 29 0a 0a not let begin)..
14f0: 3b 20 6f 6e 65 2d 20 61 6e 64 20 74 77 6f 2d 73 ; one- and two-s
1500: 69 64 65 64 20 69 66 0a 0a 20 20 20 20 3b 20 6c ided if.. ; l
1510: 69 74 65 72 61 6c 20 3c 74 65 73 74 3e 0a 20 20 iteral <test>.
1520: 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 ((ec-simplify
1530: 28 69 66 20 23 74 20 63 6f 6e 73 65 71 75 65 6e (if #t consequen
1540: 74 29 29 0a 20 20 20 20 20 63 6f 6e 73 65 71 75 t)). consequ
1550: 65 6e 74 20 29 0a 20 20 20 20 28 28 65 63 2d 73 ent ). ((ec-s
1560: 69 6d 70 6c 69 66 79 20 28 69 66 20 23 66 20 63 implify (if #f c
1570: 6f 6e 73 65 71 75 65 6e 74 29 29 0a 20 20 20 20 onsequent)).
1580: 20 28 69 66 20 23 66 20 23 66 29 20 29 0a 20 20 (if #f #f) ).
1590: 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 ((ec-simplify
15a0: 28 69 66 20 23 74 20 63 6f 6e 73 65 71 75 65 6e (if #t consequen
15b0: 74 20 61 6c 74 65 72 6e 61 74 65 29 29 0a 20 20 t alternate)).
15c0: 20 20 20 63 6f 6e 73 65 71 75 65 6e 74 20 29 0a consequent ).
15d0: 20 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 ((ec-simplif
15e0: 79 20 28 69 66 20 23 66 20 63 6f 6e 73 65 71 75 y (if #f consequ
15f0: 65 6e 74 20 61 6c 74 65 72 6e 61 74 65 29 29 0a ent alternate)).
1600: 20 20 20 20 20 61 6c 74 65 72 6e 61 74 65 20 29 alternate )
1610: 0a 0a 20 20 20 20 3b 20 28 6e 6f 74 20 28 6e 6f .. ; (not (no
1620: 74 20 3c 74 65 73 74 3e 29 29 0a 20 20 20 20 28 t <test>)). (
1630: 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 28 69 66 (ec-simplify (if
1640: 20 28 6e 6f 74 20 28 6e 6f 74 20 74 65 73 74 29 (not (not test)
1650: 29 20 63 6f 6e 73 65 71 75 65 6e 74 29 29 0a 20 ) consequent)).
1660: 20 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 (ec-simplify
1670: 20 28 69 66 20 74 65 73 74 20 63 6f 6e 73 65 71 (if test conseq
1680: 75 65 6e 74 29 29 20 29 0a 20 20 20 20 28 28 65 uent)) ). ((e
1690: 63 2d 73 69 6d 70 6c 69 66 79 20 28 69 66 20 28 c-simplify (if (
16a0: 6e 6f 74 20 28 6e 6f 74 20 74 65 73 74 29 29 20 not (not test))
16b0: 63 6f 6e 73 65 71 75 65 6e 74 20 61 6c 74 65 72 consequent alter
16c0: 6e 61 74 65 29 29 0a 20 20 20 20 20 28 65 63 2d nate)). (ec-
16d0: 73 69 6d 70 6c 69 66 79 20 28 69 66 20 74 65 73 simplify (if tes
16e0: 74 20 63 6f 6e 73 65 71 75 65 6e 74 20 61 6c 74 t consequent alt
16f0: 65 72 6e 61 74 65 29 29 20 29 0a 0a 3b 20 28 6c ernate)) )..; (l
1700: 65 74 20 28 29 20 3c 63 6f 6d 6d 61 6e 64 3e 2a et () <command>*
1710: 29 20 0a 0a 20 20 20 20 3b 20 65 6d 70 74 79 20 ) .. ; empty
1720: 3c 62 69 6e 64 69 6e 67 20 73 70 65 63 3e 2a 0a <binding spec>*.
1730: 20 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 ((ec-simplif
1740: 79 20 28 6c 65 74 20 28 29 20 63 6f 6d 6d 61 6e y (let () comman
1750: 64 20 2e 2e 2e 29 29 0a 20 20 20 20 20 28 65 63 d ...)). (ec
1760: 2d 73 69 6d 70 6c 69 66 79 20 28 62 65 67 69 6e -simplify (begin
1770: 20 63 6f 6d 6d 61 6e 64 20 2e 2e 2e 29 29 20 29 command ...)) )
1780: 0a 0a 3b 20 62 65 67 69 6e 20 0a 0a 20 20 20 20 ..; begin ..
1790: 3b 20 66 6c 61 74 74 65 6e 20 75 73 65 20 68 65 ; flatten use he
17a0: 6c 70 65 72 20 28 65 63 2d 73 69 6d 70 6c 69 66 lper (ec-simplif
17b0: 79 20 31 20 64 6f 6e 65 20 74 6f 2d 64 6f 29 0a y 1 done to-do).
17c0: 20 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 ((ec-simplif
17d0: 79 20 28 62 65 67 69 6e 20 63 6f 6d 6d 61 6e 64 y (begin command
17e0: 20 2e 2e 2e 29 29 0a 20 20 20 20 20 28 65 63 2d ...)). (ec-
17f0: 73 69 6d 70 6c 69 66 79 20 31 20 28 29 20 28 63 simplify 1 () (c
1800: 6f 6d 6d 61 6e 64 20 2e 2e 2e 29 29 20 29 0a 20 ommand ...)) ).
1810: 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 ((ec-simplify
1820: 20 31 20 64 6f 6e 65 20 28 28 62 65 67 69 6e 20 1 done ((begin
1830: 74 6f 2d 64 6f 31 20 2e 2e 2e 29 20 74 6f 2d 64 to-do1 ...) to-d
1840: 6f 32 20 2e 2e 2e 29 29 0a 20 20 20 20 20 28 65 o2 ...)). (e
1850: 63 2d 73 69 6d 70 6c 69 66 79 20 31 20 64 6f 6e c-simplify 1 don
1860: 65 20 28 74 6f 2d 64 6f 31 20 2e 2e 2e 20 74 6f e (to-do1 ... to
1870: 2d 64 6f 32 20 2e 2e 2e 29 29 20 29 0a 20 20 20 -do2 ...)) ).
1880: 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 31 ((ec-simplify 1
1890: 20 28 64 6f 6e 65 20 2e 2e 2e 29 20 28 74 6f 2d (done ...) (to-
18a0: 64 6f 31 20 74 6f 2d 64 6f 20 2e 2e 2e 29 29 0a do1 to-do ...)).
18b0: 20 20 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 (ec-simplif
18c0: 79 20 31 20 28 64 6f 6e 65 20 2e 2e 2e 20 74 6f y 1 (done ... to
18d0: 2d 64 6f 31 29 20 28 74 6f 2d 64 6f 20 2e 2e 2e -do1) (to-do ...
18e0: 29 29 20 29 0a 0a 20 20 20 20 3b 20 65 78 69 74 )) ).. ; exit
18f0: 20 68 65 6c 70 65 72 0a 20 20 20 20 28 28 65 63 helper. ((ec
1900: 2d 73 69 6d 70 6c 69 66 79 20 31 20 28 29 20 28 -simplify 1 () (
1910: 29 29 0a 20 20 20 20 20 28 69 66 20 23 66 20 23 )). (if #f #
1920: 66 29 20 29 0a 20 20 20 20 28 28 65 63 2d 73 69 f) ). ((ec-si
1930: 6d 70 6c 69 66 79 20 31 20 28 63 6f 6d 6d 61 6e mplify 1 (comman
1940: 64 29 20 28 29 29 0a 20 20 20 20 20 63 6f 6d 6d d) ()). comm
1950: 61 6e 64 20 29 0a 20 20 20 20 28 28 65 63 2d 73 and ). ((ec-s
1960: 69 6d 70 6c 69 66 79 20 31 20 28 63 6f 6d 6d 61 implify 1 (comma
1970: 6e 64 31 20 63 6f 6d 6d 61 6e 64 20 2e 2e 2e 29 nd1 command ...)
1980: 20 28 29 29 0a 20 20 20 20 20 28 62 65 67 69 6e ()). (begin
1990: 20 63 6f 6d 6d 61 6e 64 31 20 63 6f 6d 6d 61 6e command1 comman
19a0: 64 20 2e 2e 2e 29 20 29 0a 0a 3b 20 61 6e 79 74 d ...) )..; anyt
19b0: 68 69 6e 67 20 65 6c 73 65 0a 0a 20 20 20 20 28 hing else.. (
19c0: 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 65 78 70 (ec-simplify exp
19d0: 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 65 78 ression). ex
19e0: 70 72 65 73 73 69 6f 6e 20 29 29 29 0a 0a 0a 3b pression )))...;
19f0: 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ===============
1a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 ===========.; Th
1a40: 65 20 73 70 65 63 69 61 6c 20 67 65 6e 65 72 61 e special genera
1a50: 74 6f 72 73 20 3a 64 6f 2c 20 3a 6c 65 74 2c 20 tors :do, :let,
1a60: 3a 70 61 72 61 6c 6c 65 6c 2c 20 3a 77 68 69 6c :parallel, :whil
1a70: 65 2c 20 61 6e 64 20 3a 75 6e 74 69 6c 0a 3b 20 e, and :until.;
1a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
1ad0: 69 6e 65 2d 73 79 6e 74 61 78 20 3a 64 6f 0a 20 ine-syntax :do.
1ae0: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
1af0: 29 0a 0a 20 20 20 20 3b 20 66 75 6c 6c 20 64 65 ).. ; full de
1b00: 63 6f 72 61 74 65 64 20 2d 3e 20 63 6f 6e 74 69 corated -> conti
1b10: 6e 75 65 20 77 69 74 68 20 63 63 2c 20 72 65 65 nue with cc, ree
1b20: 6e 74 72 79 20 61 74 20 28 2a 29 0a 20 20 20 20 ntry at (*).
1b30: 28 28 3a 64 6f 20 28 63 63 20 2e 2e 2e 29 20 6f ((:do (cc ...) o
1b40: 6c 65 74 20 6c 62 73 20 6e 65 31 3f 20 69 6c 65 let lbs ne1? ile
1b50: 74 20 6e 65 32 3f 20 6c 73 73 29 0a 20 20 20 20 t ne2? lss).
1b60: 20 28 63 63 20 2e 2e 2e 20 28 3a 64 6f 20 6f 6c (cc ... (:do ol
1b70: 65 74 20 6c 62 73 20 6e 65 31 3f 20 69 6c 65 74 et lbs ne1? ilet
1b80: 20 6e 65 32 3f 20 6c 73 73 29 29 20 29 0a 0a 20 ne2? lss)) )..
1b90: 20 20 20 3b 20 73 68 6f 72 74 20 66 6f 72 6d 20 ; short form
1ba0: 2d 3e 20 66 69 6c 6c 20 69 6e 20 64 65 66 61 75 -> fill in defau
1bb0: 6c 74 20 76 61 6c 75 65 73 0a 20 20 20 20 28 28 lt values. ((
1bc0: 3a 64 6f 20 63 63 20 6c 62 73 20 6e 65 31 3f 20 :do cc lbs ne1?
1bd0: 6c 73 73 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 lss). (:do c
1be0: 63 20 28 6c 65 74 20 28 29 29 20 6c 62 73 20 6e c (let ()) lbs n
1bf0: 65 31 3f 20 28 6c 65 74 20 28 29 29 20 23 74 20 e1? (let ()) #t
1c00: 6c 73 73 29 20 29 29 29 0a 20 20 20 20 0a 0a 28 lss) ))). ..(
1c10: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a 6c define-syntax :l
1c20: 65 74 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c et. (syntax-rul
1c30: 65 73 20 28 69 6e 64 65 78 29 0a 20 20 20 20 28 es (index). (
1c40: 28 3a 6c 65 74 20 63 63 20 76 61 72 20 28 69 6e (:let cc var (in
1c50: 64 65 78 20 69 29 20 65 78 70 72 65 73 73 69 6f dex i) expressio
1c60: 6e 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 20 n). (:do cc
1c70: 28 6c 65 74 20 28 28 76 61 72 20 65 78 70 72 65 (let ((var expre
1c80: 73 73 69 6f 6e 29 20 28 69 20 30 29 29 29 20 28 ssion) (i 0))) (
1c90: 29 20 23 74 20 28 6c 65 74 20 28 29 29 20 23 66 ) #t (let ()) #f
1ca0: 20 28 29 29 20 29 0a 20 20 20 20 28 28 3a 6c 65 ()) ). ((:le
1cb0: 74 20 63 63 20 76 61 72 20 65 78 70 72 65 73 73 t cc var express
1cc0: 69 6f 6e 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 ion). (:do c
1cd0: 63 20 28 6c 65 74 20 28 28 76 61 72 20 65 78 70 c (let ((var exp
1ce0: 72 65 73 73 69 6f 6e 29 29 29 20 28 29 20 23 74 ression))) () #t
1cf0: 20 28 6c 65 74 20 28 29 29 20 23 66 20 28 29 29 (let ()) #f ())
1d00: 20 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 )))...(define-s
1d10: 79 6e 74 61 78 20 3a 70 61 72 61 6c 6c 65 6c 0a yntax :parallel.
1d20: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
1d30: 28 3a 64 6f 29 0a 20 20 20 20 28 28 3a 70 61 72 (:do). ((:par
1d40: 61 6c 6c 65 6c 20 63 63 29 0a 20 20 20 20 20 63 allel cc). c
1d50: 63 20 29 0a 20 20 20 20 28 28 3a 70 61 72 61 6c c ). ((:paral
1d60: 6c 65 6c 20 63 63 20 28 67 20 61 72 67 31 20 61 lel cc (g arg1 a
1d70: 72 67 20 2e 2e 2e 29 20 67 65 6e 20 2e 2e 2e 29 rg ...) gen ...)
1d80: 0a 20 20 20 20 20 28 67 20 28 3a 70 61 72 61 6c . (g (:paral
1d90: 6c 65 6c 2d 31 20 63 63 20 28 67 65 6e 20 2e 2e lel-1 cc (gen ..
1da0: 2e 29 29 20 61 72 67 31 20 61 72 67 20 2e 2e 2e .)) arg1 arg ...
1db0: 29 20 29 29 29 0a 0a 3b 20 28 3a 70 61 72 61 6c ) )))..; (:paral
1dc0: 6c 65 6c 2d 31 20 63 63 20 28 74 6f 2d 64 6f 20 lel-1 cc (to-do
1dd0: 2e 2e 2e 29 20 72 65 73 75 6c 74 20 5b 20 6e 65 ...) result [ ne
1de0: 78 74 20 5d 20 29 0a 3b 20 20 20 20 69 74 65 72 xt ] ).; iter
1df0: 61 74 65 73 20 6f 76 65 72 20 74 6f 2d 64 6f 20 ates over to-do
1e00: 62 79 20 63 6f 6e 76 65 72 74 69 6e 67 20 74 68 by converting th
1e10: 65 20 66 69 72 73 74 20 67 65 6e 65 72 61 74 6f e first generato
1e20: 72 20 69 6e 74 6f 20 0a 3b 20 20 20 20 74 68 65 r into .; the
1e30: 20 3a 64 6f 2d 67 65 6e 65 72 61 74 6f 72 20 6e :do-generator n
1e40: 65 78 74 20 61 6e 64 20 6d 65 72 67 69 6e 67 20 ext and merging
1e50: 6e 65 78 74 20 69 6e 74 6f 20 72 65 73 75 6c 74 next into result
1e60: 2e 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 ...(define-synta
1e70: 78 20 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 20 3b x :parallel-1 ;
1e80: 20 75 73 65 64 20 61 73 20 0a 20 20 28 73 79 6e used as . (syn
1e90: 74 61 78 2d 72 75 6c 65 73 20 28 3a 64 6f 20 6c tax-rules (:do l
1ea0: 65 74 29 0a 0a 20 20 20 20 3b 20 70 72 6f 63 65 et).. ; proce
1eb0: 73 73 20 6e 65 78 74 20 65 6c 65 6d 65 6e 74 20 ss next element
1ec0: 6f 66 20 74 6f 2d 64 6f 2c 20 72 65 65 6e 74 72 of to-do, reentr
1ed0: 79 20 61 74 20 28 2a 2a 29 0a 20 20 20 20 28 28 y at (**). ((
1ee0: 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 63 63 20 28 :parallel-1 cc (
1ef0: 28 67 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 (g arg1 arg ...)
1f00: 20 67 65 6e 20 2e 2e 2e 29 20 72 65 73 75 6c 74 gen ...) result
1f10: 29 0a 20 20 20 20 20 28 67 20 28 3a 70 61 72 61 ). (g (:para
1f20: 6c 6c 65 6c 2d 31 20 63 63 20 28 67 65 6e 20 2e llel-1 cc (gen .
1f30: 2e 2e 29 20 72 65 73 75 6c 74 29 20 61 72 67 31 ..) result) arg1
1f40: 20 61 72 67 20 2e 2e 2e 29 20 29 0a 0a 20 20 20 arg ...) )..
1f50: 20 3b 20 72 65 65 6e 74 72 79 20 70 6f 69 6e 74 ; reentry point
1f60: 20 28 2a 2a 29 20 2d 3e 20 6d 65 72 67 65 20 6e (**) -> merge n
1f70: 65 78 74 20 69 6e 74 6f 20 72 65 73 75 6c 74 0a ext into result.
1f80: 20 20 20 20 28 28 3a 70 61 72 61 6c 6c 65 6c 2d ((:parallel-
1f90: 31 20 0a 20 20 20 20 20 20 20 63 63 20 0a 20 20 1 . cc .
1fa0: 20 20 20 20 20 67 65 6e 73 20 0a 20 20 20 20 20 gens .
1fb0: 20 20 28 3a 64 6f 20 28 6c 65 74 20 28 6f 62 31 (:do (let (ob1
1fc0: 20 2e 2e 2e 29 20 6f 63 31 20 2e 2e 2e 29 20 0a ...) oc1 ...) .
1fd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 62 31 (lb1
1fe0: 20 2e 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 ...) .
1ff0: 20 20 20 6e 65 31 3f 31 20 0a 20 20 20 20 20 20 ne1?1 .
2000: 20 20 20 20 20 20 28 6c 65 74 20 28 69 62 31 20 (let (ib1
2010: 2e 2e 2e 29 20 69 63 31 20 2e 2e 2e 29 20 0a 20 ...) ic1 ...) .
2020: 20 20 20 20 20 20 20 20 20 20 20 6e 65 32 3f 31 ne2?1
2030: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c . (l
2040: 73 31 20 2e 2e 2e 29 20 29 0a 20 20 20 20 20 20 s1 ...) ).
2050: 20 28 3a 64 6f 20 28 6c 65 74 20 28 6f 62 32 20 (:do (let (ob2
2060: 2e 2e 2e 29 20 6f 63 32 20 2e 2e 2e 29 20 0a 20 ...) oc2 ...) .
2070: 20 20 20 20 20 20 20 20 20 20 20 28 6c 62 32 20 (lb2
2080: 2e 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 ...) .
2090: 20 20 6e 65 31 3f 32 20 0a 20 20 20 20 20 20 20 ne1?2 .
20a0: 20 20 20 20 20 28 6c 65 74 20 28 69 62 32 20 2e (let (ib2 .
20b0: 2e 2e 29 20 69 63 32 20 2e 2e 2e 29 20 0a 20 20 ..) ic2 ...) .
20c0: 20 20 20 20 20 20 20 20 20 20 6e 65 32 3f 32 20 ne2?2
20d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 73 . (ls
20e0: 32 20 2e 2e 2e 29 20 29 29 0a 20 20 20 20 20 28 2 ...) )). (
20f0: 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 0a 20 20 20 :parallel-1 .
2100: 20 20 20 20 63 63 20 0a 20 20 20 20 20 20 20 67 cc . g
2110: 65 6e 73 20 0a 20 20 20 20 20 20 20 28 3a 64 6f ens . (:do
2120: 20 28 6c 65 74 20 28 6f 62 31 20 2e 2e 2e 20 6f (let (ob1 ... o
2130: 62 32 20 2e 2e 2e 29 20 6f 63 31 20 2e 2e 2e 20 b2 ...) oc1 ...
2140: 6f 63 32 20 2e 2e 2e 29 20 0a 20 20 20 20 20 20 oc2 ...) .
2150: 20 20 20 20 20 20 28 6c 62 31 20 2e 2e 2e 20 6c (lb1 ... l
2160: 62 32 20 2e 2e 2e 29 20 0a 20 20 20 20 20 20 20 b2 ...) .
2170: 20 20 20 20 20 28 61 6e 64 20 6e 65 31 3f 31 20 (and ne1?1
2180: 6e 65 31 3f 32 29 20 0a 20 20 20 20 20 20 20 20 ne1?2) .
2190: 20 20 20 20 28 6c 65 74 20 28 69 62 31 20 2e 2e (let (ib1 ..
21a0: 2e 20 69 62 32 20 2e 2e 2e 29 20 69 63 31 20 2e . ib2 ...) ic1 .
21b0: 2e 2e 20 69 63 32 20 2e 2e 2e 29 20 0a 20 20 20 .. ic2 ...) .
21c0: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 6e 65 (and ne
21d0: 32 3f 31 20 6e 65 32 3f 32 29 20 0a 20 20 20 20 2?1 ne2?2) .
21e0: 20 20 20 20 20 20 20 20 28 6c 73 31 20 2e 2e 2e (ls1 ...
21f0: 20 6c 73 32 20 2e 2e 2e 29 20 29 29 29 0a 0a 20 ls2 ...) )))..
2200: 20 20 20 3b 20 6e 6f 20 6d 6f 72 65 20 67 65 6e ; no more gen
2210: 73 20 2d 3e 20 63 6f 6e 74 69 6e 75 65 20 77 69 s -> continue wi
2220: 74 68 20 63 63 2c 20 72 65 65 6e 74 72 79 20 61 th cc, reentry a
2230: 74 20 28 2a 29 0a 20 20 20 20 28 28 3a 70 61 72 t (*). ((:par
2240: 61 6c 6c 65 6c 2d 31 20 28 63 63 20 2e 2e 2e 29 allel-1 (cc ...)
2250: 20 28 29 20 72 65 73 75 6c 74 29 0a 20 20 20 20 () result).
2260: 20 28 63 63 20 2e 2e 2e 20 72 65 73 75 6c 74 29 (cc ... result)
2270: 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 )))..(define-sy
2280: 6e 74 61 78 20 3a 77 68 69 6c 65 0a 20 20 28 73 ntax :while. (s
2290: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
22a0: 20 20 20 28 28 3a 77 68 69 6c 65 20 63 63 20 28 ((:while cc (
22b0: 67 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 20 g arg1 arg ...)
22c0: 74 65 73 74 29 0a 20 20 20 20 20 28 67 20 28 3a test). (g (:
22d0: 77 68 69 6c 65 2d 31 20 63 63 20 74 65 73 74 29 while-1 cc test)
22e0: 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 20 29 arg1 arg ...) )
22f0: 29 29 0a 0a 3b 20 28 3a 77 68 69 6c 65 2d 31 20 ))..; (:while-1
2300: 63 63 20 74 65 73 74 20 28 3a 64 6f 20 2e 2e 2e cc test (:do ...
2310: 29 29 0a 3b 20 20 20 20 6d 6f 64 69 66 69 65 73 )).; modifies
2320: 20 74 68 65 20 66 75 6c 6c 79 20 64 65 63 6f 72 the fully decor
2330: 61 74 65 64 20 3a 64 6f 2d 67 65 6e 65 72 61 74 ated :do-generat
2340: 6f 72 20 73 75 63 68 20 74 68 61 74 20 69 74 0a or such that it.
2350: 3b 20 20 20 20 72 75 6e 73 20 77 68 69 6c 65 20 ; runs while
2360: 74 65 73 74 20 69 73 20 61 20 74 72 75 65 20 76 test is a true v
2370: 61 6c 75 65 2e 20 0a 3b 20 20 20 20 20 20 20 54 alue. .; T
2380: 68 65 20 6f 72 69 67 69 6e 61 6c 20 69 6d 70 6c he original impl
2390: 65 6d 65 6e 74 61 74 69 6f 6e 20 6a 75 73 74 20 ementation just
23a0: 72 65 70 6c 61 63 65 64 20 6e 65 31 3f 20 62 79 replaced ne1? by
23b0: 0a 3b 20 20 20 20 28 61 6e 64 20 6e 65 31 3f 20 .; (and ne1?
23c0: 74 65 73 74 29 20 61 73 20 66 6f 6c 6c 6f 77 73 test) as follows
23d0: 3a 0a 3b 0a 3b 20 20 20 20 20 20 28 64 65 66 69 :.;.; (defi
23e0: 6e 65 2d 73 79 6e 74 61 78 20 3a 77 68 69 6c 65 ne-syntax :while
23f0: 2d 31 0a 3b 20 20 20 20 20 20 20 20 28 73 79 6e -1.; (syn
2400: 74 61 78 2d 72 75 6c 65 73 20 28 3a 64 6f 29 0a tax-rules (:do).
2410: 3b 20 20 20 20 20 20 20 20 20 20 28 28 3a 77 68 ; ((:wh
2420: 69 6c 65 2d 31 20 63 63 20 74 65 73 74 20 28 3a ile-1 cc test (:
2430: 64 6f 20 6f 6c 65 74 20 6c 62 73 20 6e 65 31 3f do olet lbs ne1?
2440: 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 73 29 29 ilet ne2? lss))
2450: 0a 3b 20 20 20 20 20 20 20 20 20 20 20 28 3a 64 .; (:d
2460: 6f 20 63 63 20 6f 6c 65 74 20 6c 62 73 20 28 61 o cc olet lbs (a
2470: 6e 64 20 6e 65 31 3f 20 74 65 73 74 29 20 69 6c nd ne1? test) il
2480: 65 74 20 6e 65 32 3f 20 6c 73 73 29 20 29 29 29 et ne2? lss) )))
2490: 0a 3b 0a 3b 20 20 20 20 55 6e 66 6f 72 74 75 6e .;.; Unfortun
24a0: 61 74 65 6c 79 2c 20 74 68 69 73 20 63 6f 64 65 ately, this code
24b0: 20 69 73 20 77 72 6f 6e 67 20 62 65 63 61 75 73 is wrong becaus
24c0: 65 20 6e 65 31 3f 20 6d 61 79 20 64 65 70 65 6e e ne1? may depen
24d0: 64 0a 3b 20 20 20 20 69 6e 20 74 68 65 20 69 6e d.; in the in
24e0: 6e 65 72 20 62 69 6e 64 69 6e 67 73 20 69 6e 74 ner bindings int
24f0: 72 6f 64 75 63 65 64 20 69 6e 20 69 6c 65 74 2c roduced in ilet,
2500: 20 62 75 74 20 6e 65 31 3f 20 69 73 20 65 76 61 but ne1? is eva
2510: 6c 75 61 74 65 64 0a 3b 20 20 20 20 6f 75 74 73 luated.; outs
2520: 69 64 65 20 6f 66 20 74 68 65 20 69 6e 6e 65 72 ide of the inner
2530: 20 62 69 6e 64 69 6e 67 73 2e 20 28 52 65 66 65 bindings. (Refe
2540: 72 20 74 6f 20 74 68 65 20 73 70 65 63 69 66 69 r to the specifi
2550: 63 61 74 69 6f 6e 20 6f 66 0a 3b 20 20 20 20 3a cation of.; :
2560: 64 6f 20 74 6f 20 73 65 65 20 74 68 65 20 73 74 do to see the st
2570: 72 75 63 74 75 72 65 2e 29 20 0a 3b 20 20 20 20 ructure.) .;
2580: 20 20 20 54 68 65 20 70 72 6f 62 6c 65 6d 20 6d The problem m
2590: 61 6e 69 66 65 73 74 73 20 69 74 73 65 6c 66 20 anifests itself
25a0: 28 61 73 20 73 75 6e 6e 61 6e 40 68 61 6e 64 67 (as sunnan@handg
25b0: 72 61 6e 61 74 2e 6f 72 67 20 0a 3b 20 20 20 20 ranat.org .;
25c0: 6f 62 73 65 72 76 65 64 29 20 77 68 65 6e 20 74 observed) when t
25d0: 68 65 20 3a 6c 69 73 74 2d 67 65 6e 65 72 61 74 he :list-generat
25e0: 6f 72 20 69 73 20 6d 6f 64 69 66 69 65 64 3a 0a or is modified:.
25f0: 3b 20 0a 3b 20 20 20 20 20 20 28 64 6f 2d 65 63 ; .; (do-ec
2600: 20 28 3a 77 68 69 6c 65 20 28 3a 6c 69 73 74 20 (:while (:list
2610: 78 20 27 28 31 20 32 29 29 20 28 3d 20 78 20 31 x '(1 2)) (= x 1
2620: 29 29 20 28 64 69 73 70 6c 61 79 20 78 29 29 2e )) (display x)).
2630: 0a 3b 0a 3b 20 20 20 20 49 6e 20 6f 72 64 65 72 .;.; In order
2640: 20 74 6f 20 67 65 6e 65 72 61 74 65 20 70 72 6f to generate pro
2650: 70 65 72 20 63 6f 64 65 2c 20 77 65 20 69 6e 74 per code, we int
2660: 72 6f 64 75 63 65 20 74 65 6d 70 6f 72 61 72 79 roduce temporary
2670: 0a 3b 20 20 20 20 76 61 72 69 61 62 6c 65 73 20 .; variables
2680: 73 61 76 69 6e 67 20 74 68 65 20 76 61 6c 75 65 saving the value
2690: 73 20 6f 66 20 74 68 65 20 69 6e 6e 65 72 20 62 s of the inner b
26a0: 69 6e 64 69 6e 67 73 2e 20 54 68 65 20 69 6e 6e indings. The inn
26b0: 65 72 0a 3b 20 20 20 20 62 69 6e 64 69 6e 67 73 er.; bindings
26c0: 20 61 72 65 20 65 78 65 63 75 74 65 64 20 69 6e are executed in
26d0: 20 61 20 6e 65 77 20 6e 65 31 3f 2c 20 77 68 69 a new ne1?, whi
26e0: 63 68 20 61 6c 73 6f 20 65 76 61 6c 75 61 74 65 ch also evaluate
26f0: 73 20 6e 65 31 3f 0a 3b 20 20 20 20 6f 75 74 73 s ne1?.; outs
2700: 69 64 65 20 74 68 65 20 73 63 6f 70 65 20 6f 66 ide the scope of
2710: 20 74 68 65 20 69 6e 6e 65 72 20 62 69 6e 64 69 the inner bindi
2720: 6e 67 73 2c 20 74 68 65 6e 20 74 68 65 20 69 6e ngs, then the in
2730: 6e 65 72 20 63 6f 6d 6d 61 6e 64 73 0a 3b 20 20 ner commands.;
2740: 20 20 61 72 65 20 65 78 65 63 75 74 65 64 20 28 are executed (
2750: 70 6f 73 73 69 62 6c 79 20 63 68 61 6e 67 69 6e possibly changin
2760: 67 20 74 68 65 20 76 61 72 69 61 62 6c 65 73 29 g the variables)
2770: 2c 20 61 6e 64 20 74 68 65 6e 20 74 68 65 0a 3b , and then the.;
2780: 20 20 20 20 76 61 6c 75 65 73 20 6f 66 20 74 68 values of th
2790: 65 20 69 6e 6e 65 72 20 62 69 6e 64 69 6e 67 73 e inner bindings
27a0: 20 61 72 65 20 73 61 76 65 64 20 61 6e 64 20 28 are saved and (
27b0: 61 6e 64 20 6e 65 31 3f 20 74 65 73 74 29 20 69 and ne1? test) i
27c0: 73 0a 3b 20 20 20 20 72 65 74 75 72 6e 65 64 2e s.; returned.
27d0: 20 49 6e 20 74 68 65 20 6e 65 77 20 69 6c 65 74 In the new ilet
27e0: 2c 20 74 68 65 20 69 6e 6e 65 72 20 76 61 72 69 , the inner vari
27f0: 61 62 6c 65 73 20 61 72 65 20 62 6f 75 6e 64 20 ables are bound
2800: 61 6e 64 0a 3b 20 20 20 20 69 6e 69 74 69 61 6c and.; initial
2810: 69 7a 65 64 20 61 6e 64 20 74 68 65 69 72 20 76 ized and their v
2820: 61 6c 75 65 73 20 61 72 65 20 72 65 73 74 6f 72 alues are restor
2830: 65 64 2e 20 53 6f 20 77 65 20 63 6f 6e 73 74 72 ed. So we constr
2840: 75 63 74 3a 0a 3b 0a 3b 20 20 20 20 20 28 6c 65 uct:.;.; (le
2850: 74 20 28 6f 62 20 2e 2e 20 28 69 62 2d 74 6d 70 t (ob .. (ib-tmp
2860: 20 23 66 29 20 2e 2e 2e 29 0a 3b 20 20 20 20 20 #f) ...).;
2870: 20 20 6f 63 20 2e 2e 2e 0a 3b 20 20 20 20 20 20 oc ....;
2880: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 6c 62 20 2e (let loop (lb .
2890: 2e 2e 29 0a 3b 20 20 20 20 20 20 20 20 20 28 69 ..).; (i
28a0: 66 20 28 6c 65 74 20 28 6e 65 31 3f 2d 76 61 6c f (let (ne1?-val
28b0: 75 65 20 6e 65 31 3f 29 0a 3b 20 20 20 20 20 20 ue ne1?).;
28c0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
28d0: 69 62 2d 76 61 72 20 69 62 2d 72 68 73 29 20 2e ib-var ib-rhs) .
28e0: 2e 2e 29 0a 3b 20 20 20 20 20 20 20 20 20 20 20 ..).;
28f0: 20 20 20 20 20 20 69 63 20 2e 2e 2e 0a 3b 20 20 ic ....;
2900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2910: 73 65 74 21 20 69 62 2d 74 6d 70 20 69 62 2d 76 set! ib-tmp ib-v
2920: 61 72 29 20 2e 2e 2e 29 0a 3b 20 20 20 20 20 20 ar) ...).;
2930: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 6e 65 (and ne
2940: 31 3f 2d 76 61 6c 75 65 20 74 65 73 74 29 29 0a 1?-value test)).
2950: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ; (l
2960: 65 74 20 28 28 69 62 2d 76 61 72 20 69 62 2d 74 et ((ib-var ib-t
2970: 6d 70 29 20 2e 2e 2e 29 0a 3b 20 20 20 20 20 20 mp) ...).;
2980: 20 20 20 20 20 20 20 20 20 2f 70 61 79 6c 6f 61 /payloa
2990: 64 2f 0a 3b 20 20 20 20 20 20 20 20 20 20 20 20 d/.;
29a0: 20 20 20 28 69 66 20 6e 65 32 3f 0a 3b 20 20 20 (if ne2?.;
29b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
29c0: 28 6c 6f 6f 70 20 6c 73 20 2e 2e 2e 29 20 29 29 (loop ls ...) ))
29d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e )))..(define-syn
29e0: 74 61 78 20 3a 77 68 69 6c 65 2d 31 0a 20 20 28 tax :while-1. (
29f0: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 3a 64 syntax-rules (:d
2a00: 6f 20 6c 65 74 29 0a 20 20 20 20 28 28 3a 77 68 o let). ((:wh
2a10: 69 6c 65 2d 31 20 63 63 20 74 65 73 74 20 28 3a ile-1 cc test (:
2a20: 64 6f 20 6f 6c 65 74 20 6c 62 73 20 6e 65 31 3f do olet lbs ne1?
2a30: 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 73 29 29 ilet ne2? lss))
2a40: 0a 20 20 20 20 20 28 3a 77 68 69 6c 65 2d 32 20 . (:while-2
2a50: 63 63 20 74 65 73 74 20 28 29 20 28 29 20 28 29 cc test () () ()
2a60: 20 28 3a 64 6f 20 6f 6c 65 74 20 6c 62 73 20 6e (:do olet lbs n
2a70: 65 31 3f 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 e1? ilet ne2? ls
2a80: 73 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d s)))))..(define-
2a90: 73 79 6e 74 61 78 20 3a 77 68 69 6c 65 2d 32 0a syntax :while-2.
2aa0: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
2ab0: 28 3a 64 6f 20 6c 65 74 29 0a 20 20 20 20 28 28 (:do let). ((
2ac0: 3a 77 68 69 6c 65 2d 32 20 63 63 20 0a 20 20 20 :while-2 cc .
2ad0: 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 74 test
2ae0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2af0: 20 28 69 62 2d 6c 65 74 20 20 20 20 20 2e 2e 2e (ib-let ...
2b00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2b10: 20 28 69 62 2d 73 61 76 65 20 20 20 20 2e 2e 2e (ib-save ...
2b20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2b30: 20 28 69 62 2d 72 65 73 74 6f 72 65 20 2e 2e 2e (ib-restore ...
2b40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2b50: 20 28 3a 64 6f 20 6f 6c 65 74 20 0a 20 20 20 20 (:do olet .
2b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b70: 6c 62 73 20 0a 20 20 20 20 20 20 20 20 20 20 20 lbs .
2b80: 20 20 20 20 20 20 20 20 20 6e 65 31 3f 20 0a 20 ne1? .
2b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ba0: 20 20 20 28 6c 65 74 20 28 28 69 62 2d 76 61 72 (let ((ib-var
2bb0: 20 69 62 2d 72 68 73 29 20 69 62 20 2e 2e 2e 29 ib-rhs) ib ...)
2bc0: 20 69 63 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 ic ...).
2bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 32 ne2
2be0: 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ? .
2bf0: 20 20 20 20 20 20 20 6c 73 73 29 29 0a 20 20 20 lss)).
2c00: 20 20 28 3a 77 68 69 6c 65 2d 32 20 63 63 20 0a (:while-2 cc .
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
2c20: 65 73 74 20 0a 20 20 20 20 20 20 20 20 20 20 20 est .
2c30: 20 20 20 20 28 69 62 2d 6c 65 74 20 20 20 20 20 (ib-let
2c40: 2e 2e 2e 20 28 69 62 2d 74 6d 70 20 23 66 29 29 ... (ib-tmp #f))
2c50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2c60: 28 69 62 2d 73 61 76 65 20 20 20 20 2e 2e 2e 20 (ib-save ...
2c70: 28 69 62 2d 76 61 72 20 69 62 2d 72 68 73 29 29 (ib-var ib-rhs))
2c80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2c90: 28 69 62 2d 72 65 73 74 6f 72 65 20 2e 2e 2e 20 (ib-restore ...
2ca0: 28 69 62 2d 76 61 72 20 69 62 2d 74 6d 70 29 29 (ib-var ib-tmp))
2cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2cc0: 28 3a 64 6f 20 6f 6c 65 74 20 0a 20 20 20 20 20 (:do olet .
2cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6c l
2ce0: 62 73 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 bs .
2cf0: 20 20 20 20 20 20 20 20 6e 65 31 3f 20 0a 20 20 ne1? .
2d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d10: 20 20 28 6c 65 74 20 28 69 62 20 2e 2e 2e 29 20 (let (ib ...)
2d20: 69 63 20 2e 2e 2e 20 28 73 65 74 21 20 69 62 2d ic ... (set! ib-
2d30: 74 6d 70 20 69 62 2d 76 61 72 29 29 20 0a 20 20 tmp ib-var)) .
2d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d50: 20 20 6e 65 32 3f 20 0a 20 20 20 20 20 20 20 20 ne2? .
2d60: 20 20 20 20 20 20 20 20 20 20 20 20 6c 73 73 29 lss)
2d70: 29 29 0a 20 20 20 20 28 28 3a 77 68 69 6c 65 2d )). ((:while-
2d80: 32 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 20 2 cc.
2d90: 20 20 20 20 74 65 73 74 0a 20 20 20 20 20 20 20 test.
2da0: 20 20 20 20 20 20 20 20 28 69 62 2d 6c 65 74 20 (ib-let
2db0: 20 20 20 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 ...).
2dc0: 20 20 20 20 20 20 20 20 28 69 62 2d 73 61 76 65 (ib-save
2dd0: 20 20 20 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 ...).
2de0: 20 20 20 20 20 20 20 20 28 69 62 2d 72 65 73 74 (ib-rest
2df0: 6f 72 65 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 ore ...).
2e00: 20 20 20 20 20 20 20 20 28 3a 64 6f 20 28 6c 65 (:do (le
2e10: 74 20 28 6f 62 20 2e 2e 2e 29 20 6f 63 20 2e 2e t (ob ...) oc ..
2e20: 2e 29 20 6c 62 73 20 6e 65 31 3f 20 28 6c 65 74 .) lbs ne1? (let
2e30: 20 28 29 20 69 63 20 2e 2e 2e 29 20 6e 65 32 3f () ic ...) ne2?
2e40: 20 6c 73 73 29 29 0a 20 20 20 20 20 28 3a 64 6f lss)). (:do
2e50: 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c cc. (l
2e60: 65 74 20 28 6f 62 20 2e 2e 2e 20 69 62 2d 6c 65 et (ob ... ib-le
2e70: 74 20 2e 2e 2e 29 20 6f 63 20 2e 2e 2e 29 0a 20 t ...) oc ...).
2e80: 20 20 20 20 20 20 20 20 20 6c 62 73 0a 20 20 20 lbs.
2e90: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 (let ((ne
2ea0: 31 3f 2d 76 61 6c 75 65 20 6e 65 31 3f 29 29 0a 1?-value ne1?)).
2eb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
2ec0: 20 28 69 62 2d 73 61 76 65 20 2e 2e 2e 29 0a 20 (ib-save ...).
2ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69 i
2ee0: 63 20 2e 2e 2e 0a 20 20 20 20 20 20 20 20 20 20 c ....
2ef0: 20 20 20 20 20 20 28 61 6e 64 20 6e 65 31 3f 2d (and ne1?-
2f00: 76 61 6c 75 65 20 74 65 73 74 29 29 29 0a 20 20 value test))).
2f10: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 69 62 (let (ib
2f20: 2d 72 65 73 74 6f 72 65 20 2e 2e 2e 29 29 0a 20 -restore ...)).
2f30: 20 20 20 20 20 20 20 20 20 6e 65 32 3f 0a 20 20 ne2?.
2f40: 20 20 20 20 20 20 20 20 6c 73 73 29 29 29 29 0a lss)))).
2f50: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
2f60: 20 3a 75 6e 74 69 6c 0a 20 20 28 73 79 6e 74 61 :until. (synta
2f70: 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 x-rules (). (
2f80: 28 3a 75 6e 74 69 6c 20 63 63 20 28 67 20 61 72 (:until cc (g ar
2f90: 67 31 20 61 72 67 20 2e 2e 2e 29 20 74 65 73 74 g1 arg ...) test
2fa0: 29 0a 20 20 20 20 20 28 67 20 28 3a 75 6e 74 69 ). (g (:unti
2fb0: 6c 2d 31 20 63 63 20 74 65 73 74 29 20 61 72 67 l-1 cc test) arg
2fc0: 31 20 61 72 67 20 2e 2e 2e 29 20 29 29 29 0a 0a 1 arg ...) )))..
2fd0: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a (define-syntax :
2fe0: 75 6e 74 69 6c 2d 31 0a 20 20 28 73 79 6e 74 61 until-1. (synta
2ff0: 78 2d 72 75 6c 65 73 20 28 3a 64 6f 29 0a 20 20 x-rules (:do).
3000: 20 20 28 28 3a 75 6e 74 69 6c 2d 31 20 63 63 20 ((:until-1 cc
3010: 74 65 73 74 20 28 3a 64 6f 20 6f 6c 65 74 20 6c test (:do olet l
3020: 62 73 20 6e 65 31 3f 20 69 6c 65 74 20 6e 65 32 bs ne1? ilet ne2
3030: 3f 20 6c 73 73 29 29 0a 20 20 20 20 20 28 3a 64 ? lss)). (:d
3040: 6f 20 63 63 20 6f 6c 65 74 20 6c 62 73 20 6e 65 o cc olet lbs ne
3050: 31 3f 20 69 6c 65 74 20 28 61 6e 64 20 6e 65 32 1? ilet (and ne2
3060: 3f 20 28 6e 6f 74 20 74 65 73 74 29 29 20 6c 73 ? (not test)) ls
3070: 73 29 20 29 29 29 0a 0a 0a 3b 20 3d 3d 3d 3d 3d s) )))...; =====
3080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30c0: 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 74 79 70 65 =====.; The type
30d0: 64 20 67 65 6e 65 72 61 74 6f 72 73 20 3a 6c 69 d generators :li
30e0: 73 74 20 3a 73 74 72 69 6e 67 20 3a 76 65 63 74 st :string :vect
30f0: 6f 72 20 65 74 63 2e 0a 3b 20 3d 3d 3d 3d 3d 3d or etc..; ======
3100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3140: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ====..(define-sy
3150: 6e 74 61 78 20 3a 6c 69 73 74 0a 20 20 28 73 79 ntax :list. (sy
3160: 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 65 ntax-rules (inde
3170: 78 29 0a 20 20 20 20 28 28 3a 6c 69 73 74 20 63 x). ((:list c
3180: 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 c var (index i)
3190: 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a arg ...). (:
31a0: 70 61 72 61 6c 6c 65 6c 20 63 63 20 28 3a 6c 69 parallel cc (:li
31b0: 73 74 20 76 61 72 20 61 72 67 20 2e 2e 2e 29 20 st var arg ...)
31c0: 28 3a 69 6e 74 65 67 65 72 73 20 69 29 29 20 29 (:integers i)) )
31d0: 0a 20 20 20 20 28 28 3a 6c 69 73 74 20 63 63 20 . ((:list cc
31e0: 76 61 72 20 61 72 67 31 20 61 72 67 32 20 61 72 var arg1 arg2 ar
31f0: 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 6c 69 g ...). (:li
3200: 73 74 20 63 63 20 76 61 72 20 28 61 70 70 65 6e st cc var (appen
3210: 64 20 61 72 67 31 20 61 72 67 32 20 61 72 67 20 d arg1 arg2 arg
3220: 2e 2e 2e 29 29 20 29 0a 20 20 20 20 28 28 3a 6c ...)) ). ((:l
3230: 69 73 74 20 63 63 20 76 61 72 20 61 72 67 29 0a ist cc var arg).
3240: 20 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 (:do cc.
3250: 20 20 20 20 20 20 20 28 6c 65 74 20 28 29 29 0a (let ()).
3260: 20 20 20 20 20 20 20 20 20 20 28 28 74 20 61 72 ((t ar
3270: 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6e g)). (n
3280: 6f 74 20 28 6e 75 6c 6c 3f 20 74 29 29 0a 20 20 ot (null? t)).
3290: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 (let ((v
32a0: 61 72 20 28 63 61 72 20 74 29 29 29 29 0a 20 20 ar (car t)))).
32b0: 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 #t.
32c0: 20 20 20 20 20 28 28 63 64 72 20 74 29 29 20 29 ((cdr t)) )
32d0: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 79 )))...(define-sy
32e0: 6e 74 61 78 20 3a 73 74 72 69 6e 67 0a 20 20 28 ntax :string. (
32f0: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 6e syntax-rules (in
3300: 64 65 78 29 0a 20 20 20 20 28 28 3a 73 74 72 69 dex). ((:stri
3310: 6e 67 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 ng cc var (index
3320: 20 69 29 20 61 72 67 29 0a 20 20 20 20 20 28 3a i) arg). (:
3330: 64 6f 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 do cc.
3340: 28 6c 65 74 20 28 28 73 74 72 20 61 72 67 29 20 (let ((str arg)
3350: 28 6c 65 6e 20 30 29 29 20 0a 20 20 20 20 20 20 (len 0)) .
3360: 20 20 20 20 20 20 28 73 65 74 21 20 6c 65 6e 20 (set! len
3370: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 73 (string-length s
3380: 74 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 tr))).
3390: 28 28 69 20 30 29 29 0a 20 20 20 20 20 20 20 20 ((i 0)).
33a0: 20 20 28 3c 20 69 20 6c 65 6e 29 0a 20 20 20 20 (< i len).
33b0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 (let ((var
33c0: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 73 74 72 (string-ref str
33d0: 20 69 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 i)))).
33e0: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 #t. ((
33f0: 2b 20 69 20 31 29 29 20 29 29 0a 20 20 20 20 28 + i 1)) )). (
3400: 28 3a 73 74 72 69 6e 67 20 63 63 20 76 61 72 20 (:string cc var
3410: 28 69 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 (index i) arg1 a
3420: 72 67 32 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 rg2 arg ...).
3430: 20 20 28 3a 73 74 72 69 6e 67 20 63 63 20 76 61 (:string cc va
3440: 72 20 28 69 6e 64 65 78 20 69 29 20 28 73 74 72 r (index i) (str
3450: 69 6e 67 2d 61 70 70 65 6e 64 20 61 72 67 31 20 ing-append arg1
3460: 61 72 67 32 20 61 72 67 20 2e 2e 2e 29 29 20 29 arg2 arg ...)) )
3470: 0a 20 20 20 20 28 28 3a 73 74 72 69 6e 67 20 63 . ((:string c
3480: 63 20 76 61 72 20 61 72 67 31 20 61 72 67 20 2e c var arg1 arg .
3490: 2e 2e 29 0a 20 20 20 20 20 28 3a 73 74 72 69 6e ..). (:strin
34a0: 67 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 g cc var (index
34b0: 69 29 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 i) arg1 arg ...)
34c0: 20 29 29 29 0a 0a 3b 20 41 6c 74 65 72 6e 61 74 )))..; Alternat
34d0: 69 76 65 3a 20 41 6e 20 69 6d 70 6c 65 6d 65 6e ive: An implemen
34e0: 74 61 74 69 6f 6e 20 69 6e 20 74 68 65 20 73 74 tation in the st
34f0: 79 6c 65 20 6f 66 20 3a 76 65 63 74 6f 72 20 63 yle of :vector c
3500: 61 6e 20 61 6c 73 6f 0a 3b 20 20 20 62 65 20 75 an also.; be u
3510: 73 65 64 20 66 6f 72 20 3a 73 74 72 69 6e 67 2e sed for :string.
3520: 20 48 6f 77 65 76 65 72 2c 20 69 74 20 69 73 20 However, it is
3530: 6c 65 73 73 20 69 6e 74 65 72 65 73 74 69 6e 67 less interesting
3540: 20 61 73 20 74 68 65 0a 3b 20 20 20 6f 76 65 72 as the.; over
3550: 68 65 61 64 20 6f 66 20 73 74 72 69 6e 67 2d 61 head of string-a
3560: 70 70 65 6e 64 20 69 73 20 6d 75 63 68 20 6c 65 ppend is much le
3570: 73 73 20 74 68 61 6e 20 66 6f 72 20 27 76 65 63 ss than for 'vec
3580: 74 6f 72 2d 61 70 70 65 6e 64 27 2e 0a 0a 0a 28 tor-append'....(
3590: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a 76 define-syntax :v
35a0: 65 63 74 6f 72 0a 20 20 28 73 79 6e 74 61 78 2d ector. (syntax-
35b0: 72 75 6c 65 73 20 28 69 6e 64 65 78 29 0a 20 20 rules (index).
35c0: 20 20 28 28 3a 76 65 63 74 6f 72 20 63 63 20 76 ((:vector cc v
35d0: 61 72 20 61 72 67 29 0a 20 20 20 20 20 28 3a 76 ar arg). (:v
35e0: 65 63 74 6f 72 20 63 63 20 76 61 72 20 28 69 6e ector cc var (in
35f0: 64 65 78 20 69 29 20 61 72 67 29 20 29 0a 20 20 dex i) arg) ).
3600: 20 20 28 28 3a 76 65 63 74 6f 72 20 63 63 20 76 ((:vector cc v
3610: 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 67 ar (index i) arg
3620: 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 ). (:do cc.
3630: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
3640: 76 65 63 20 61 72 67 29 20 28 6c 65 6e 20 30 29 vec arg) (len 0)
3650: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ) . (
3660: 73 65 74 21 20 6c 65 6e 20 28 76 65 63 74 6f 72 set! len (vector
3670: 2d 6c 65 6e 67 74 68 20 76 65 63 29 29 29 0a 20 -length vec))).
3680: 20 20 20 20 20 20 20 20 20 28 28 69 20 30 29 29 ((i 0))
3690: 0a 20 20 20 20 20 20 20 20 20 20 28 3c 20 69 20 . (< i
36a0: 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 28 len). (
36b0: 6c 65 74 20 28 28 76 61 72 20 28 76 65 63 74 6f let ((var (vecto
36c0: 72 2d 72 65 66 20 76 65 63 20 69 29 29 29 29 0a r-ref vec i)))).
36d0: 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 #t.
36e0: 20 20 20 20 20 20 20 28 28 2b 20 69 20 31 29 29 ((+ i 1))
36f0: 20 29 29 0a 0a 20 20 20 20 28 28 3a 76 65 63 74 )).. ((:vect
3700: 6f 72 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 or cc var (index
3710: 20 69 29 20 61 72 67 31 20 61 72 67 32 20 61 72 i) arg1 arg2 ar
3720: 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 70 61 g ...). (:pa
3730: 72 61 6c 6c 65 6c 20 63 63 20 28 3a 76 65 63 74 rallel cc (:vect
3740: 6f 72 20 63 63 20 76 61 72 20 61 72 67 31 20 61 or cc var arg1 a
3750: 72 67 32 20 61 72 67 20 2e 2e 2e 29 20 28 3a 69 rg2 arg ...) (:i
3760: 6e 74 65 67 65 72 73 20 69 29 29 20 29 0a 20 20 ntegers i)) ).
3770: 20 20 28 28 3a 76 65 63 74 6f 72 20 63 63 20 76 ((:vector cc v
3780: 61 72 20 61 72 67 31 20 61 72 67 32 20 61 72 67 ar arg1 arg2 arg
3790: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 64 6f 20 ...). (:do
37a0: 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 cc. (le
37b0: 74 20 28 28 76 65 63 20 23 66 29 0a 20 20 20 20 t ((vec #f).
37c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 6e (len
37d0: 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0).
37e0: 20 20 20 20 28 76 65 63 73 20 28 65 63 2d 3a 76 (vecs (ec-:v
37f0: 65 63 74 6f 72 2d 66 69 6c 74 65 72 20 28 6c 69 ector-filter (li
3800: 73 74 20 61 72 67 31 20 61 72 67 32 20 61 72 67 st arg1 arg2 arg
3810: 20 2e 2e 2e 29 29 29 20 29 29 0a 20 20 20 20 20 ...))) )).
3820: 20 20 20 20 20 28 28 6b 20 30 29 29 0a 20 20 20 ((k 0)).
3830: 20 20 20 20 20 20 20 28 69 66 20 28 3c 20 6b 20 (if (< k
3840: 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 len).
3850: 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 #t.
3860: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 76 (if (null? v
3870: 65 63 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 ecs).
3880: 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 #f.
3890: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
38a0: 69 6e 20 28 73 65 74 21 20 76 65 63 20 28 63 61 in (set! vec (ca
38b0: 72 20 76 65 63 73 29 29 0a 20 20 20 20 20 20 20 r vecs)).
38c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38d0: 20 20 28 73 65 74 21 20 76 65 63 73 20 28 63 64 (set! vecs (cd
38e0: 72 20 76 65 63 73 29 29 0a 20 20 20 20 20 20 20 r vecs)).
38f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3900: 20 20 28 73 65 74 21 20 6c 65 6e 20 28 76 65 63 (set! len (vec
3910: 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 63 29 29 tor-length vec))
3920: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3930: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
3940: 6b 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 20 k 0).
3950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 74 #t
3960: 20 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 ))). (
3970: 6c 65 74 20 28 28 76 61 72 20 28 76 65 63 74 6f let ((var (vecto
3980: 72 2d 72 65 66 20 76 65 63 20 6b 29 29 29 29 0a r-ref vec k)))).
3990: 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 #t.
39a0: 20 20 20 20 20 20 20 28 28 2b 20 6b 20 31 29 29 ((+ k 1))
39b0: 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ))))..(define (
39c0: 65 63 2d 3a 76 65 63 74 6f 72 2d 66 69 6c 74 65 ec-:vector-filte
39d0: 72 20 76 65 63 73 29 0a 20 20 28 69 66 20 28 6e r vecs). (if (n
39e0: 75 6c 6c 3f 20 76 65 63 73 29 0a 20 20 20 20 20 ull? vecs).
39f0: 20 27 28 29 0a 20 20 20 20 20 20 28 69 66 20 28 '(). (if (
3a00: 7a 65 72 6f 3f 20 28 76 65 63 74 6f 72 2d 6c 65 zero? (vector-le
3a10: 6e 67 74 68 20 28 63 61 72 20 76 65 63 73 29 29 ngth (car vecs))
3a20: 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 63 2d ). (ec-
3a30: 3a 76 65 63 74 6f 72 2d 66 69 6c 74 65 72 20 28 :vector-filter (
3a40: 63 64 72 20 76 65 63 73 29 29 0a 20 20 20 20 20 cdr vecs)).
3a50: 20 20 20 20 20 28 63 6f 6e 73 20 28 63 61 72 20 (cons (car
3a60: 76 65 63 73 29 20 28 65 63 2d 3a 76 65 63 74 6f vecs) (ec-:vecto
3a70: 72 2d 66 69 6c 74 65 72 20 28 63 64 72 20 76 65 r-filter (cdr ve
3a80: 63 73 29 29 29 20 29 29 29 0a 0a 3b 20 41 6c 74 cs))) )))..; Alt
3a90: 65 72 6e 61 74 69 76 65 3a 20 41 20 73 69 6d 70 ernative: A simp
3aa0: 6c 65 72 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 ler implementati
3ab0: 6f 6e 20 66 6f 72 20 3a 76 65 63 74 6f 72 20 75 on for :vector u
3ac0: 73 65 73 20 76 65 63 74 6f 72 2d 3e 6c 69 73 74 ses vector->list
3ad0: 0a 3b 20 20 20 61 70 70 65 6e 64 20 61 6e 64 20 .; append and
3ae0: 3a 6c 69 73 74 20 69 6e 20 74 68 65 20 6d 75 6c :list in the mul
3af0: 74 69 2d 61 72 67 75 6d 65 6e 74 20 63 61 73 65 ti-argument case
3b00: 2e 20 50 6c 65 61 73 65 20 72 65 66 65 72 20 74 . Please refer t
3b10: 6f 20 74 68 65 0a 3b 20 20 20 27 64 65 73 69 67 o the.; 'desig
3b20: 6e 2e 73 63 6d 27 20 66 6f 72 20 6d 6f 72 65 20 n.scm' for more
3b30: 64 65 74 61 69 6c 73 2e 0a 0a 0a 28 64 65 66 69 details....(defi
3b40: 6e 65 2d 73 79 6e 74 61 78 20 3a 69 6e 74 65 67 ne-syntax :integ
3b50: 65 72 73 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 ers. (syntax-ru
3b60: 6c 65 73 20 28 69 6e 64 65 78 29 0a 20 20 20 20 les (index).
3b70: 28 28 3a 69 6e 74 65 67 65 72 73 20 63 63 20 76 ((:integers cc v
3b80: 61 72 20 28 69 6e 64 65 78 20 69 29 29 0a 20 20 ar (index i)).
3b90: 20 20 20 28 3a 64 6f 20 63 63 20 28 28 76 61 72 (:do cc ((var
3ba0: 20 30 29 20 28 69 20 30 29 29 20 23 74 20 28 28 0) (i 0)) #t ((
3bb0: 2b 20 76 61 72 20 31 29 20 28 2b 20 69 20 31 29 + var 1) (+ i 1)
3bc0: 29 29 20 29 0a 20 20 20 20 28 28 3a 69 6e 74 65 )) ). ((:inte
3bd0: 67 65 72 73 20 63 63 20 76 61 72 29 0a 20 20 20 gers cc var).
3be0: 20 20 28 3a 64 6f 20 63 63 20 28 28 76 61 72 20 (:do cc ((var
3bf0: 30 29 29 20 23 74 20 28 28 2b 20 76 61 72 20 31 0)) #t ((+ var 1
3c00: 29 29 29 20 29 29 29 0a 0a 0a 28 64 65 66 69 6e ))) )))...(defin
3c10: 65 2d 73 79 6e 74 61 78 20 3a 72 61 6e 67 65 0a e-syntax :range.
3c20: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
3c30: 28 69 6e 64 65 78 29 0a 0a 20 20 20 20 3b 20 68 (index).. ; h
3c40: 61 6e 64 6c 65 20 69 6e 64 65 78 20 76 61 72 69 andle index vari
3c50: 61 62 6c 65 20 61 6e 64 20 61 64 64 20 6f 70 74 able and add opt
3c60: 69 6f 6e 61 6c 20 61 72 67 73 0a 20 20 20 20 28 ional args. (
3c70: 28 3a 72 61 6e 67 65 20 63 63 20 76 61 72 20 28 (:range cc var (
3c80: 69 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 72 index i) arg1 ar
3c90: 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 70 61 g ...). (:pa
3ca0: 72 61 6c 6c 65 6c 20 63 63 20 28 3a 72 61 6e 67 rallel cc (:rang
3cb0: 65 20 76 61 72 20 61 72 67 31 20 61 72 67 20 2e e var arg1 arg .
3cc0: 2e 2e 29 20 28 3a 69 6e 74 65 67 65 72 73 20 69 ..) (:integers i
3cd0: 29 29 20 29 0a 20 20 20 20 28 28 3a 72 61 6e 67 )) ). ((:rang
3ce0: 65 20 63 63 20 76 61 72 20 61 72 67 31 29 0a 20 e cc var arg1).
3cf0: 20 20 20 20 28 3a 72 61 6e 67 65 20 63 63 20 76 (:range cc v
3d00: 61 72 20 30 20 61 72 67 31 20 31 29 20 29 0a 20 ar 0 arg1 1) ).
3d10: 20 20 20 28 28 3a 72 61 6e 67 65 20 63 63 20 76 ((:range cc v
3d20: 61 72 20 61 72 67 31 20 61 72 67 32 29 0a 20 20 ar arg1 arg2).
3d30: 20 20 20 28 3a 72 61 6e 67 65 20 63 63 20 76 61 (:range cc va
3d40: 72 20 61 72 67 31 20 61 72 67 32 20 31 29 20 29 r arg1 arg2 1) )
3d50: 0a 0a 3b 20 73 70 65 63 69 61 6c 20 63 61 73 65 ..; special case
3d60: 73 20 28 70 61 72 74 69 61 6c 6c 79 20 65 76 61 s (partially eva
3d70: 6c 75 61 74 65 64 20 62 79 20 68 61 6e 64 20 66 luated by hand f
3d80: 72 6f 6d 20 67 65 6e 65 72 61 6c 20 63 61 73 65 rom general case
3d90: 29 0a 0a 20 20 20 20 28 28 3a 72 61 6e 67 65 20 ).. ((:range
3da0: 63 63 20 76 61 72 20 30 20 61 72 67 32 20 31 29 cc var 0 arg2 1)
3db0: 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 20 . (:do cc.
3dc0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 62 (let ((b
3dd0: 20 61 72 67 32 29 29 0a 20 20 20 20 20 20 20 20 arg2)).
3de0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 61 6e (if (not (an
3df0: 64 20 28 69 6e 74 65 67 65 72 3f 20 62 29 20 28 d (integer? b) (
3e00: 65 78 61 63 74 3f 20 62 29 29 29 0a 20 20 20 20 exact? b))).
3e10: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
3e20: 6f 72 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 or .
3e30: 20 20 20 20 20 20 20 22 61 72 67 75 6d 65 6e 74 "argument
3e40: 73 20 6f 66 20 3a 72 61 6e 67 65 20 61 72 65 20 s of :range are
3e50: 6e 6f 74 20 65 78 61 63 74 20 69 6e 74 65 67 65 not exact intege
3e60: 72 20 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 r ".
3e70: 20 20 20 20 20 20 20 22 28 75 73 65 20 3a 72 65 "(use :re
3e80: 61 6c 2d 72 61 6e 67 65 3f 29 22 20 30 20 62 20 al-range?)" 0 b
3e90: 31 20 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 1 ))).
3ea0: 28 28 76 61 72 20 30 29 29 0a 20 20 20 20 20 20 ((var 0)).
3eb0: 20 20 20 20 28 3c 20 76 61 72 20 62 29 0a 20 20 (< var b).
3ec0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 29 29 (let ())
3ed0: 0a 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 . #t.
3ee0: 20 20 20 20 20 20 20 20 28 28 2b 20 76 61 72 20 ((+ var
3ef0: 31 29 29 20 29 29 0a 0a 20 20 20 20 28 28 3a 72 1)) )).. ((:r
3f00: 61 6e 67 65 20 63 63 20 76 61 72 20 30 20 61 72 ange cc var 0 ar
3f10: 67 32 20 2d 31 29 0a 20 20 20 20 20 28 3a 64 6f g2 -1). (:do
3f20: 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c cc. (l
3f30: 65 74 20 28 28 62 20 61 72 67 32 29 29 0a 20 20 et ((b arg2)).
3f40: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
3f50: 6f 74 20 28 61 6e 64 20 28 69 6e 74 65 67 65 72 ot (and (integer
3f60: 3f 20 62 29 20 28 65 78 61 63 74 3f 20 62 29 29 ? b) (exact? b))
3f70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3f80: 20 20 28 65 72 72 6f 72 20 0a 20 20 20 20 20 20 (error .
3f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 61 72 "ar
3fa0: 67 75 6d 65 6e 74 73 20 6f 66 20 3a 72 61 6e 67 guments of :rang
3fb0: 65 20 61 72 65 20 6e 6f 74 20 65 78 61 63 74 20 e are not exact
3fc0: 69 6e 74 65 67 65 72 20 22 0a 20 20 20 20 20 20 integer ".
3fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 28 75 "(u
3fe0: 73 65 20 3a 72 65 61 6c 2d 72 61 6e 67 65 3f 29 se :real-range?)
3ff0: 22 20 30 20 62 20 31 20 29 29 29 0a 20 20 20 20 " 0 b 1 ))).
4000: 20 20 20 20 20 20 28 28 76 61 72 20 30 29 29 0a ((var 0)).
4010: 20 20 20 20 20 20 20 20 20 20 28 3e 20 76 61 72 (> var
4020: 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c b). (l
4030: 65 74 20 28 29 29 0a 20 20 20 20 20 20 20 20 20 et ()).
4040: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 #t. ((
4050: 2d 20 76 61 72 20 31 29 29 20 29 29 0a 0a 20 20 - var 1)) ))..
4060: 20 20 28 28 3a 72 61 6e 67 65 20 63 63 20 76 61 ((:range cc va
4070: 72 20 61 72 67 31 20 61 72 67 32 20 31 29 0a 20 r arg1 arg2 1).
4080: 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 (:do cc.
4090: 20 20 20 20 20 20 28 6c 65 74 20 28 28 61 20 61 (let ((a a
40a0: 72 67 31 29 20 28 62 20 61 72 67 32 29 29 0a 20 rg1) (b arg2)).
40b0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
40c0: 6e 6f 74 20 28 61 6e 64 20 28 69 6e 74 65 67 65 not (and (intege
40d0: 72 3f 20 61 29 20 28 65 78 61 63 74 3f 20 61 29 r? a) (exact? a)
40e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
40f0: 20 20 20 20 20 20 20 20 20 20 20 28 69 6e 74 65 (inte
4100: 67 65 72 3f 20 62 29 20 28 65 78 61 63 74 3f 20 ger? b) (exact?
4110: 62 29 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 b) )).
4120: 20 20 20 20 20 20 28 65 72 72 6f 72 20 0a 20 20 (error .
4130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4140: 20 22 61 72 67 75 6d 65 6e 74 73 20 6f 66 20 3a "arguments of :
4150: 72 61 6e 67 65 20 61 72 65 20 6e 6f 74 20 65 78 range are not ex
4160: 61 63 74 20 69 6e 74 65 67 65 72 20 22 0a 20 20 act integer ".
4170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4180: 20 22 28 75 73 65 20 3a 72 65 61 6c 2d 72 61 6e "(use :real-ran
4190: 67 65 3f 29 22 20 61 20 62 20 31 20 29 29 20 29 ge?)" a b 1 )) )
41a0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 76 61 72 . ((var
41b0: 20 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 a)). (
41c0: 3c 20 76 61 72 20 62 29 0a 20 20 20 20 20 20 20 < var b).
41d0: 20 20 20 28 6c 65 74 20 28 29 29 0a 20 20 20 20 (let ()).
41e0: 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 #t.
41f0: 20 20 20 28 28 2b 20 76 61 72 20 31 29 29 20 29 ((+ var 1)) )
4200: 29 0a 0a 20 20 20 20 28 28 3a 72 61 6e 67 65 20 ).. ((:range
4210: 63 63 20 76 61 72 20 61 72 67 31 20 61 72 67 32 cc var arg1 arg2
4220: 20 2d 31 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 -1). (:do c
4230: 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 c. (let
4240: 20 28 28 61 20 61 72 67 31 29 20 28 62 20 61 72 ((a arg1) (b ar
4250: 67 32 29 20 28 73 20 2d 31 29 20 28 73 74 6f 70 g2) (s -1) (stop
4260: 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 0)).
4270: 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 28 (if (not (and (
4280: 69 6e 74 65 67 65 72 3f 20 61 29 20 28 65 78 61 integer? a) (exa
4290: 63 74 3f 20 61 29 0a 20 20 20 20 20 20 20 20 20 ct? a).
42a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
42b0: 20 28 69 6e 74 65 67 65 72 3f 20 62 29 20 28 65 (integer? b) (e
42c0: 78 61 63 74 3f 20 62 29 20 29 29 0a 20 20 20 20 xact? b) )).
42d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
42e0: 6f 72 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 or .
42f0: 20 20 20 20 20 20 20 22 61 72 67 75 6d 65 6e 74 "argument
4300: 73 20 6f 66 20 3a 72 61 6e 67 65 20 61 72 65 20 s of :range are
4310: 6e 6f 74 20 65 78 61 63 74 20 69 6e 74 65 67 65 not exact intege
4320: 72 20 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 r ".
4330: 20 20 20 20 20 20 20 22 28 75 73 65 20 3a 72 65 "(use :re
4340: 61 6c 2d 72 61 6e 67 65 3f 29 22 20 61 20 62 20 al-range?)" a b
4350: 2d 31 20 29 29 20 29 0a 20 20 20 20 20 20 20 20 -1 )) ).
4360: 20 20 28 28 76 61 72 20 61 29 29 0a 20 20 20 20 ((var a)).
4370: 20 20 20 20 20 20 28 3e 20 76 61 72 20 62 29 0a (> var b).
4380: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
4390: 29 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 0a )). #t.
43a0: 20 20 20 20 20 20 20 20 20 20 28 28 2d 20 76 61 ((- va
43b0: 72 20 31 29 29 20 29 29 0a 0a 3b 20 74 68 65 20 r 1)) ))..; the
43c0: 67 65 6e 65 72 61 6c 20 63 61 73 65 0a 0a 20 20 general case..
43d0: 20 20 28 28 3a 72 61 6e 67 65 20 63 63 20 76 61 ((:range cc va
43e0: 72 20 61 72 67 31 20 61 72 67 32 20 61 72 67 33 r arg1 arg2 arg3
43f0: 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 ). (:do cc.
4400: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
4410: 61 20 61 72 67 31 29 20 28 62 20 61 72 67 32 29 a arg1) (b arg2)
4420: 20 28 73 20 61 72 67 33 29 20 28 73 74 6f 70 20 (s arg3) (stop
4430: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
4440: 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 28 69 (if (not (and (i
4450: 6e 74 65 67 65 72 3f 20 61 29 20 28 65 78 61 63 nteger? a) (exac
4460: 74 3f 20 61 29 0a 20 20 20 20 20 20 20 20 20 20 t? a).
4470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4480: 28 69 6e 74 65 67 65 72 3f 20 62 29 20 28 65 78 (integer? b) (ex
4490: 61 63 74 3f 20 62 29 0a 20 20 20 20 20 20 20 20 act? b).
44a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44b0: 20 20 28 69 6e 74 65 67 65 72 3f 20 73 29 20 28 (integer? s) (
44c0: 65 78 61 63 74 3f 20 73 29 20 29 29 0a 20 20 20 exact? s) )).
44d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 (er
44e0: 72 6f 72 20 0a 20 20 20 20 20 20 20 20 20 20 20 ror .
44f0: 20 20 20 20 20 20 20 20 22 61 72 67 75 6d 65 6e "argumen
4500: 74 73 20 6f 66 20 3a 72 61 6e 67 65 20 61 72 65 ts of :range are
4510: 20 6e 6f 74 20 65 78 61 63 74 20 69 6e 74 65 67 not exact integ
4520: 65 72 20 22 0a 20 20 20 20 20 20 20 20 20 20 20 er ".
4530: 20 20 20 20 20 20 20 20 22 28 75 73 65 20 3a 72 "(use :r
4540: 65 61 6c 2d 72 61 6e 67 65 3f 29 22 20 61 20 62 eal-range?)" a b
4550: 20 73 20 29 29 0a 20 20 20 20 20 20 20 20 20 20 s )).
4560: 20 20 28 69 66 20 28 7a 65 72 6f 3f 20 73 29 0a (if (zero? s).
4570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4580: 28 65 72 72 6f 72 20 22 73 74 65 70 20 73 69 7a (error "step siz
4590: 65 20 6d 75 73 74 20 6e 6f 74 20 62 65 20 7a 65 e must not be ze
45a0: 72 6f 20 69 6e 20 3a 72 61 6e 67 65 22 29 20 29 ro in :range") )
45b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 . (se
45c0: 74 21 20 73 74 6f 70 20 28 2b 20 61 20 28 2a 20 t! stop (+ a (*
45d0: 28 6d 61 78 20 30 20 28 63 65 69 6c 69 6e 67 20 (max 0 (ceiling
45e0: 28 2f 20 28 2d 20 62 20 61 29 20 73 29 29 29 20 (/ (- b a) s)))
45f0: 73 29 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 s))) ).
4600: 20 28 28 76 61 72 20 61 29 29 0a 20 20 20 20 20 ((var a)).
4610: 20 20 20 20 20 28 6e 6f 74 20 28 3d 20 76 61 72 (not (= var
4620: 20 73 74 6f 70 29 29 0a 20 20 20 20 20 20 20 20 stop)).
4630: 20 20 28 6c 65 74 20 28 29 29 0a 20 20 20 20 20 (let ()).
4640: 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 #t.
4650: 20 20 28 28 2b 20 76 61 72 20 73 29 29 20 29 29 ((+ var s)) ))
4660: 29 29 0a 0a 3b 20 43 6f 6d 6d 65 6e 74 3a 20 54 ))..; Comment: T
4670: 68 65 20 6d 61 63 72 6f 20 3a 72 61 6e 67 65 20 he macro :range
4680: 69 6e 73 65 72 74 73 20 73 6f 6d 65 20 63 6f 64 inserts some cod
4690: 65 20 74 6f 20 6d 61 6b 65 20 73 75 72 65 20 74 e to make sure t
46a0: 68 65 20 76 61 6c 75 65 73 0a 3b 20 20 20 61 72 he values.; ar
46b0: 65 20 65 78 61 63 74 20 69 6e 74 65 67 65 72 73 e exact integers
46c0: 2e 20 54 68 69 73 20 6f 76 65 72 68 65 61 64 20 . This overhead
46d0: 68 61 73 20 70 72 6f 76 65 6e 20 76 65 72 79 20 has proven very
46e0: 68 65 6c 70 66 75 6c 20 66 6f 72 20 0a 3b 20 20 helpful for .;
46f0: 20 73 61 76 69 6e 67 20 75 73 65 72 73 20 66 72 saving users fr
4700: 6f 6d 20 74 68 65 6d 73 65 6c 76 65 73 2e 0a 0a om themselves...
4710: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax
4720: 3a 72 65 61 6c 2d 72 61 6e 67 65 0a 20 20 28 73 :real-range. (s
4730: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 yntax-rules (ind
4740: 65 78 29 0a 0a 20 20 20 20 3b 20 61 64 64 20 6f ex).. ; add o
4750: 70 74 69 6f 6e 61 6c 20 61 72 67 73 20 61 6e 64 ptional args and
4760: 20 69 6e 64 65 78 20 76 61 72 69 61 62 6c 65 0a index variable.
4770: 20 20 20 20 28 28 3a 72 65 61 6c 2d 72 61 6e 67 ((:real-rang
4780: 65 20 63 63 20 76 61 72 20 61 72 67 31 29 0a 20 e cc var arg1).
4790: 20 20 20 20 28 3a 72 65 61 6c 2d 72 61 6e 67 65 (:real-range
47a0: 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 cc var (index i
47b0: 29 20 30 20 61 72 67 31 20 31 29 20 29 0a 20 20 ) 0 arg1 1) ).
47c0: 20 20 28 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 ((:real-range
47d0: 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 cc var (index i)
47e0: 20 61 72 67 31 29 0a 20 20 20 20 20 28 3a 72 65 arg1). (:re
47f0: 61 6c 2d 72 61 6e 67 65 20 63 63 20 76 61 72 20 al-range cc var
4800: 28 69 6e 64 65 78 20 69 29 20 30 20 61 72 67 31 (index i) 0 arg1
4810: 20 31 29 20 29 0a 20 20 20 20 28 28 3a 72 65 61 1) ). ((:rea
4820: 6c 2d 72 61 6e 67 65 20 63 63 20 76 61 72 20 61 l-range cc var a
4830: 72 67 31 20 61 72 67 32 29 0a 20 20 20 20 20 28 rg1 arg2). (
4840: 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 20 76 :real-range cc v
4850: 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 67 ar (index i) arg
4860: 31 20 61 72 67 32 20 31 29 20 29 0a 20 20 20 20 1 arg2 1) ).
4870: 28 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 ((:real-range cc
4880: 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 var (index i) a
4890: 72 67 31 20 61 72 67 32 29 0a 20 20 20 20 20 28 rg1 arg2). (
48a0: 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 20 76 :real-range cc v
48b0: 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 67 ar (index i) arg
48c0: 31 20 61 72 67 32 20 31 29 20 29 0a 20 20 20 20 1 arg2 1) ).
48d0: 28 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 ((:real-range cc
48e0: 20 76 61 72 20 61 72 67 31 20 61 72 67 32 20 61 var arg1 arg2 a
48f0: 72 67 33 29 0a 20 20 20 20 20 28 3a 72 65 61 6c rg3). (:real
4900: 2d 72 61 6e 67 65 20 63 63 20 76 61 72 20 28 69 -range cc var (i
4910: 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 72 67 ndex i) arg1 arg
4920: 32 20 61 72 67 33 29 20 29 0a 0a 20 20 20 20 3b 2 arg3) ).. ;
4930: 20 74 68 65 20 66 75 6c 6c 79 20 71 75 61 6c 69 the fully quali
4940: 66 69 65 64 20 63 61 73 65 0a 20 20 20 20 28 28 fied case. ((
4950: 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 20 76 :real-range cc v
4960: 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 67 ar (index i) arg
4970: 31 20 61 72 67 32 20 61 72 67 33 29 0a 20 20 20 1 arg2 arg3).
4980: 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 20 (:do cc.
4990: 20 20 20 20 28 6c 65 74 20 28 28 61 20 61 72 67 (let ((a arg
49a0: 31 29 20 28 62 20 61 72 67 32 29 20 28 73 20 61 1) (b arg2) (s a
49b0: 72 67 33 29 20 28 69 73 74 6f 70 20 30 29 29 0a rg3) (istop 0)).
49c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
49d0: 28 6e 6f 74 20 28 61 6e 64 20 28 72 65 61 6c 3f (not (and (real?
49e0: 20 61 29 20 28 72 65 61 6c 3f 20 62 29 20 28 72 a) (real? b) (r
49f0: 65 61 6c 3f 20 73 29 29 29 0a 20 20 20 20 20 20 eal? s))).
4a00: 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 (error
4a10: 20 22 61 72 67 75 6d 65 6e 74 73 20 6f 66 20 3a "arguments of :
4a20: 72 65 61 6c 2d 72 61 6e 67 65 20 61 72 65 20 6e real-range are n
4a30: 6f 74 20 72 65 61 6c 22 20 61 20 62 20 73 29 20 ot real" a b s)
4a40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 ). (i
4a50: 66 20 28 61 6e 64 20 28 65 78 61 63 74 3f 20 61 f (and (exact? a
4a60: 29 20 28 6f 72 20 28 6e 6f 74 20 28 65 78 61 63 ) (or (not (exac
4a70: 74 3f 20 62 29 29 20 28 6e 6f 74 20 28 65 78 61 t? b)) (not (exa
4a80: 63 74 3f 20 73 29 29 29 29 0a 20 20 20 20 20 20 ct? s)))).
4a90: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
4aa0: 61 20 28 65 78 61 63 74 2d 3e 69 6e 65 78 61 63 a (exact->inexac
4ab0: 74 20 61 29 29 20 29 0a 20 20 20 20 20 20 20 20 t a)) ).
4ac0: 20 20 20 20 28 73 65 74 21 20 69 73 74 6f 70 20 (set! istop
4ad0: 28 2f 20 28 2d 20 62 20 61 29 20 73 29 29 20 29 (/ (- b a) s)) )
4ae0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 69 20 30 . ((i 0
4af0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 3c 20 )). (<
4b00: 69 20 69 73 74 6f 70 29 0a 20 20 20 20 20 20 20 i istop).
4b10: 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 2b (let ((var (+
4b20: 20 61 20 28 2a 20 73 20 69 29 29 29 29 29 0a 20 a (* s i))))).
4b30: 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 #t.
4b40: 20 20 20 20 20 20 28 28 2b 20 69 20 31 29 29 20 ((+ i 1))
4b50: 29 29 29 29 0a 0a 3b 20 43 6f 6d 6d 65 6e 74 3a ))))..; Comment:
4b60: 20 54 68 65 20 6d 61 63 72 6f 20 3a 72 65 61 6c The macro :real
4b70: 2d 72 61 6e 67 65 20 61 64 61 70 74 73 20 74 68 -range adapts th
4b80: 65 20 65 78 61 63 74 6e 65 73 73 20 6f 66 20 74 e exactness of t
4b90: 68 65 20 73 74 61 72 74 0a 3b 20 20 20 76 61 6c he start.; val
4ba0: 75 65 20 69 6e 20 63 61 73 65 20 61 6e 79 20 6f ue in case any o
4bb0: 66 20 74 68 65 20 6f 74 68 65 72 20 76 61 6c 75 f the other valu
4bc0: 65 73 20 69 73 20 69 6e 65 78 61 63 74 2e 20 54 es is inexact. T
4bd0: 68 69 73 20 69 73 20 61 0a 3b 20 20 20 70 72 65 his is a.; pre
4be0: 63 61 75 74 69 6f 6e 20 74 6f 20 61 76 6f 69 64 caution to avoid
4bf0: 20 28 6c 69 73 74 2d 65 63 20 28 3a 20 78 20 30 (list-ec (: x 0
4c00: 20 33 2e 30 29 20 78 29 20 3d 3e 20 27 28 30 20 3.0) x) => '(0
4c10: 31 2e 30 20 32 2e 30 29 2e 0a 0a 20 20 20 20 0a 1.0 2.0)... .
4c20: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a (define-syntax :
4c30: 63 68 61 72 2d 72 61 6e 67 65 0a 20 20 28 73 79 char-range. (sy
4c40: 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 65 ntax-rules (inde
4c50: 78 29 0a 20 20 20 20 28 28 3a 63 68 61 72 2d 72 x). ((:char-r
4c60: 61 6e 67 65 20 63 63 20 76 61 72 20 28 69 6e 64 ange cc var (ind
4c70: 65 78 20 69 29 20 61 72 67 31 20 61 72 67 32 29 ex i) arg1 arg2)
4c80: 0a 20 20 20 20 20 28 3a 70 61 72 61 6c 6c 65 6c . (:parallel
4c90: 20 63 63 20 28 3a 63 68 61 72 2d 72 61 6e 67 65 cc (:char-range
4ca0: 20 76 61 72 20 61 72 67 31 20 61 72 67 32 29 20 var arg1 arg2)
4cb0: 28 3a 69 6e 74 65 67 65 72 73 20 69 29 29 20 29 (:integers i)) )
4cc0: 0a 20 20 20 20 28 28 3a 63 68 61 72 2d 72 61 6e . ((:char-ran
4cd0: 67 65 20 63 63 20 76 61 72 20 61 72 67 31 20 61 ge cc var arg1 a
4ce0: 72 67 32 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 rg2). (:do c
4cf0: 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 c. (let
4d00: 20 28 28 69 6d 61 78 20 28 63 68 61 72 2d 3e 69 ((imax (char->i
4d10: 6e 74 65 67 65 72 20 61 72 67 32 29 29 29 29 0a nteger arg2)))).
4d20: 20 20 20 20 20 20 20 20 20 20 28 28 69 20 28 63 ((i (c
4d30: 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 61 72 67 har->integer arg
4d40: 31 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 1))). (
4d50: 3c 3d 20 69 20 69 6d 61 78 29 0a 20 20 20 20 20 <= i imax).
4d60: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 (let ((var
4d70: 28 69 6e 74 65 67 65 72 2d 3e 63 68 61 72 20 69 (integer->char i
4d80: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 23 )))). #
4d90: 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 2b 20 t. ((+
4da0: 69 20 31 29 29 20 29 29 29 29 0a 0a 3b 20 57 61 i 1)) ))))..; Wa
4db0: 72 6e 69 6e 67 3a 20 54 68 65 72 65 20 69 73 20 rning: There is
4dc0: 6e 6f 20 52 35 52 53 2d 77 61 79 20 74 6f 20 69 no R5RS-way to i
4dd0: 6d 70 6c 65 6d 65 6e 74 20 74 68 65 20 3a 63 68 mplement the :ch
4de0: 61 72 2d 72 61 6e 67 65 20 67 65 6e 65 72 61 74 ar-range generat
4df0: 6f 72 20 0a 3b 20 20 20 62 65 63 61 75 73 65 20 or .; because
4e00: 74 68 65 20 69 6e 74 65 67 65 72 73 20 6f 62 74 the integers obt
4e10: 61 69 6e 65 64 20 62 79 20 63 68 61 72 2d 3e 69 ained by char->i
4e20: 6e 74 65 67 65 72 20 61 72 65 20 6e 6f 74 20 6e nteger are not n
4e30: 65 63 65 73 73 61 72 69 6c 79 20 0a 3b 20 20 20 ecessarily .;
4e40: 63 6f 6e 73 65 63 75 74 69 76 65 2e 20 57 65 20 consecutive. We
4e50: 73 69 6d 70 6c 79 20 61 73 73 75 6d 65 20 74 68 simply assume th
4e60: 69 73 20 61 6e 79 68 6f 77 20 66 6f 72 20 69 6c is anyhow for il
4e70: 6c 75 73 74 72 61 74 69 6f 6e 2e 0a 0a 0a 28 64 lustration....(d
4e80: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a 70 6f efine-syntax :po
4e90: 72 74 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c rt. (syntax-rul
4ea0: 65 73 20 28 69 6e 64 65 78 29 0a 20 20 20 20 28 es (index). (
4eb0: 28 3a 70 6f 72 74 20 63 63 20 76 61 72 20 28 69 (:port cc var (i
4ec0: 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 72 67 ndex i) arg1 arg
4ed0: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 70 61 72 ...). (:par
4ee0: 61 6c 6c 65 6c 20 63 63 20 28 3a 70 6f 72 74 20 allel cc (:port
4ef0: 76 61 72 20 61 72 67 31 20 61 72 67 20 2e 2e 2e var arg1 arg ...
4f00: 29 20 28 3a 69 6e 74 65 67 65 72 73 20 69 29 29 ) (:integers i))
4f10: 20 29 0a 20 20 20 20 28 28 3a 70 6f 72 74 20 63 ). ((:port c
4f20: 63 20 76 61 72 20 61 72 67 29 0a 20 20 20 20 20 c var arg).
4f30: 28 3a 70 6f 72 74 20 63 63 20 76 61 72 20 61 72 (:port cc var ar
4f40: 67 20 72 65 61 64 29 20 29 0a 20 20 20 20 28 28 g read) ). ((
4f50: 3a 70 6f 72 74 20 63 63 20 76 61 72 20 61 72 67 :port cc var arg
4f60: 31 20 61 72 67 32 29 0a 20 20 20 20 20 28 3a 64 1 arg2). (:d
4f70: 6f 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 o cc. (
4f80: 6c 65 74 20 28 28 70 6f 72 74 20 61 72 67 31 29 let ((port arg1)
4f90: 20 28 72 65 61 64 2d 70 72 6f 63 20 61 72 67 32 (read-proc arg2
4fa0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 ))). ((
4fb0: 76 61 72 20 28 72 65 61 64 2d 70 72 6f 63 20 70 var (read-proc p
4fc0: 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 ort))).
4fd0: 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 (not (eof-objec
4fe0: 74 3f 20 76 61 72 29 29 0a 20 20 20 20 20 20 20 t? var)).
4ff0: 20 20 20 28 6c 65 74 20 28 29 29 0a 20 20 20 20 (let ()).
5000: 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 #t.
5010: 20 20 20 28 28 72 65 61 64 2d 70 72 6f 63 20 70 ((read-proc p
5020: 6f 72 74 29 29 20 29 29 29 29 0a 0a 0a 3b 20 3d ort)) ))))...; =
5030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 =========.; The
5080: 74 79 70 65 64 20 67 65 6e 65 72 61 74 6f 72 20 typed generator
5090: 3a 64 69 73 70 61 74 63 68 65 64 20 61 6e 64 20 :dispatched and
50a0: 75 74 69 6c 69 74 69 65 73 20 66 6f 72 20 63 6f utilities for co
50b0: 6e 73 74 72 75 63 74 69 6e 67 20 64 69 73 70 61 nstructing dispa
50c0: 74 63 68 65 72 73 0a 3b 20 3d 3d 3d 3d 3d 3d 3d tchers.; =======
50d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5110: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e ===..(define-syn
5120: 74 61 78 20 3a 64 69 73 70 61 74 63 68 65 64 0a tax :dispatched.
5130: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
5140: 28 69 6e 64 65 78 29 0a 20 20 20 20 28 28 3a 64 (index). ((:d
5150: 69 73 70 61 74 63 68 65 64 20 63 63 20 76 61 72 ispatched cc var
5160: 20 28 69 6e 64 65 78 20 69 29 20 64 69 73 70 61 (index i) dispa
5170: 74 63 68 20 61 72 67 31 20 61 72 67 20 2e 2e 2e tch arg1 arg ...
5180: 29 0a 20 20 20 20 20 28 3a 70 61 72 61 6c 6c 65 ). (:paralle
5190: 6c 20 63 63 20 0a 20 20 20 20 20 20 20 20 20 20 l cc .
51a0: 20 20 20 20 20 20 28 3a 69 6e 74 65 67 65 72 73 (:integers
51b0: 20 69 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 i).
51c0: 20 20 20 20 28 3a 64 69 73 70 61 74 63 68 65 64 (:dispatched
51d0: 20 76 61 72 20 64 69 73 70 61 74 63 68 20 61 72 var dispatch ar
51e0: 67 31 20 61 72 67 20 2e 2e 2e 29 20 29 29 0a 20 g1 arg ...) )).
51f0: 20 20 20 28 28 3a 64 69 73 70 61 74 63 68 65 64 ((:dispatched
5200: 20 63 63 20 76 61 72 20 64 69 73 70 61 74 63 68 cc var dispatch
5210: 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 0a 20 arg1 arg ...).
5220: 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 (:do cc.
5230: 20 20 20 20 20 20 28 6c 65 74 20 28 28 64 20 64 (let ((d d
5240: 69 73 70 61 74 63 68 29 20 0a 20 20 20 20 20 20 ispatch) .
5250: 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 20 (args
5260: 28 6c 69 73 74 20 61 72 67 31 20 61 72 67 20 2e (list arg1 arg .
5270: 2e 2e 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 ..)) .
5280: 20 20 20 20 20 20 28 67 20 23 66 29 20 0a 20 20 (g #f) .
5290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
52a0: 6d 70 74 79 20 28 6c 69 73 74 20 23 66 29 29 20 mpty (list #f))
52b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 ). (s
52c0: 65 74 21 20 67 20 28 64 20 61 72 67 73 29 29 0a et! g (d args)).
52d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
52e0: 28 6e 6f 74 20 28 70 72 6f 63 65 64 75 72 65 3f (not (procedure?
52f0: 20 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 g)).
5300: 20 20 20 20 20 28 65 72 72 6f 72 20 22 75 6e 72 (error "unr
5310: 65 63 6f 67 6e 69 7a 65 64 20 61 72 67 75 6d 65 ecognized argume
5320: 6e 74 73 20 69 6e 20 64 69 73 70 61 74 63 68 69 nts in dispatchi
5330: 6e 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 ng" .
5340: 20 20 20 20 20 20 20 20 20 20 20 20 61 72 67 73 args
5350: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5360: 20 20 20 20 20 20 20 20 20 28 64 20 27 28 29 29 (d '())
5370: 20 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 ))). (
5380: 28 76 61 72 20 28 67 20 65 6d 70 74 79 29 29 29 (var (g empty)))
5390: 0a 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 . (not
53a0: 28 65 71 3f 20 76 61 72 20 65 6d 70 74 79 29 29 (eq? var empty))
53b0: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 . (let
53c0: 28 29 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 ()). #t
53d0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 67 20 65 . ((g e
53e0: 6d 70 74 79 29 29 20 29 29 29 29 0a 0a 3b 20 43 mpty)) ))))..; C
53f0: 6f 6d 6d 65 6e 74 3a 20 54 68 65 20 75 6e 69 71 omment: The uniq
5400: 75 65 20 6f 62 6a 65 63 74 20 65 6d 70 74 79 20 ue object empty
5410: 69 73 20 63 72 65 61 74 65 64 20 61 73 20 61 20 is created as a
5420: 6e 65 77 6c 79 20 61 6c 6c 6f 63 61 74 65 64 0a newly allocated.
5430: 3b 20 20 20 6e 6f 6e 2d 65 6d 70 74 79 20 6c 69 ; non-empty li
5440: 73 74 2e 20 49 74 20 69 73 20 63 6f 6d 70 61 72 st. It is compar
5450: 65 64 20 75 73 69 6e 67 20 65 71 3f 20 77 68 69 ed using eq? whi
5460: 63 68 20 64 69 73 74 69 6e 67 75 69 73 68 65 73 ch distinguishes
5470: 0a 3b 20 20 20 74 68 65 20 6f 62 6a 65 63 74 20 .; the object
5480: 66 72 6f 6d 20 61 6e 79 20 6f 74 68 65 72 20 6f from any other o
5490: 62 6a 65 63 74 2c 20 61 63 63 6f 72 64 69 6e 67 bject, according
54a0: 20 74 6f 20 52 35 52 53 20 36 2e 31 2e 0a 0a 0a to R5RS 6.1....
54b0: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a (define-syntax :
54c0: 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 0a 20 generator-proc.
54d0: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
54e0: 3a 64 6f 20 6c 65 74 29 0a 0a 20 20 20 20 3b 20 :do let).. ;
54f0: 63 61 6c 6c 20 67 20 77 69 74 68 20 61 20 76 61 call g with a va
5500: 72 69 61 62 6c 65 2c 20 72 65 65 6e 74 72 79 20 riable, reentry
5510: 61 74 20 28 2a 2a 29 0a 20 20 20 20 28 28 3a 67 at (**). ((:g
5520: 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 67 enerator-proc (g
5530: 20 61 72 67 20 2e 2e 2e 29 29 0a 20 20 20 20 20 arg ...)).
5540: 28 67 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 (g (:generator-p
5550: 72 6f 63 20 76 61 72 29 20 76 61 72 20 61 72 67 roc var) var arg
5560: 20 2e 2e 2e 29 20 29 0a 0a 20 20 20 20 3b 20 72 ...) ).. ; r
5570: 65 65 6e 74 72 79 20 70 6f 69 6e 74 20 28 2a 2a eentry point (**
5580: 29 20 2d 3e 20 6d 61 6b 65 20 74 68 65 20 63 6f ) -> make the co
5590: 64 65 20 66 72 6f 6d 20 61 20 73 69 6e 67 6c 65 de from a single
55a0: 20 3a 64 6f 0a 20 20 20 20 28 28 3a 67 65 6e 65 :do. ((:gene
55b0: 72 61 74 6f 72 2d 70 72 6f 63 0a 20 20 20 20 20 rator-proc.
55c0: 20 20 76 61 72 20 0a 20 20 20 20 20 20 20 28 3a var . (:
55d0: 64 6f 20 28 6c 65 74 20 6f 62 73 20 6f 63 20 2e do (let obs oc .
55e0: 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ..) .
55f0: 20 28 28 6c 76 20 6c 69 29 20 2e 2e 2e 29 20 0a ((lv li) ...) .
5600: 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 31 3f ne1?
5610: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c . (l
5620: 65 74 20 28 28 69 20 76 29 20 2e 2e 2e 29 20 69 et ((i v) ...) i
5630: 63 20 2e 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 c ...) .
5640: 20 20 20 20 6e 65 32 3f 20 0a 20 20 20 20 20 20 ne2? .
5650: 20 20 20 20 20 20 28 6c 73 20 2e 2e 2e 29 29 20 (ls ...))
5660: 29 0a 20 20 20 20 20 28 65 63 2d 73 69 6d 70 6c ). (ec-simpl
5670: 69 66 79 20 0a 20 20 20 20 20 20 28 6c 65 74 20 ify . (let
5680: 6f 62 73 0a 20 20 20 20 20 20 20 20 20 20 6f 63 obs. oc
5690: 20 2e 2e 2e 0a 20 20 20 20 20 20 20 20 20 20 28 .... (
56a0: 6c 65 74 20 28 28 6c 76 20 6c 69 29 20 2e 2e 2e let ((lv li) ...
56b0: 20 28 6e 65 32 20 23 74 29 29 0a 20 20 20 20 20 (ne2 #t)).
56c0: 20 20 20 20 20 20 20 28 65 63 2d 73 69 6d 70 6c (ec-simpl
56d0: 69 66 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 ify.
56e0: 20 28 6c 65 74 20 28 28 69 20 23 66 29 20 2e 2e (let ((i #f) ..
56f0: 2e 29 20 3b 20 76 20 6e 6f 74 20 79 65 74 20 76 .) ; v not yet v
5700: 61 6c 69 64 0a 20 20 20 20 20 20 20 20 20 20 20 alid.
5710: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 65 6d 70 (lambda (emp
5720: 74 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ty).
5730: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 6e 65 (if (and ne
5740: 31 3f 20 6e 65 32 29 0a 20 20 20 20 20 20 20 20 1? ne2).
5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 63 (ec
5760: 2d 73 69 6d 70 6c 69 66 79 0a 20 20 20 20 20 20 -simplify.
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5780: 28 62 65 67 69 6e 20 0a 20 20 20 20 20 20 20 20 (begin .
5790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57a0: 28 73 65 74 21 20 69 20 76 29 20 2e 2e 2e 0a 20 (set! i v) ....
57b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57c0: 20 20 20 20 20 20 20 69 63 20 2e 2e 2e 0a 20 20 ic ....
57d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57e0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c (let ((val
57f0: 75 65 20 76 61 72 29 29 0a 20 20 20 20 20 20 20 ue var)).
5800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5810: 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 0a (ec-simplify.
5820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5830: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 6e (if n
5840: 65 32 3f 0a 20 20 20 20 20 20 20 20 20 20 20 20 e2?.
5850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5860: 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 (ec-simplify
5870: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5890: 20 28 62 65 67 69 6e 20 28 73 65 74 21 20 6c 76 (begin (set! lv
58a0: 20 6c 73 29 20 2e 2e 2e 29 20 29 0a 20 20 20 20 ls) ...) ).
58b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58c0: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
58d0: 20 6e 65 32 20 23 66 29 20 29 29 0a 20 20 20 20 ne2 #f) )).
58e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58f0: 20 20 20 20 20 20 76 61 6c 75 65 20 29 29 29 0a value ))).
5900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5910: 20 20 20 20 20 65 6d 70 74 79 20 29 29 29 29 29 empty )))))
5920: 29 29 29 0a 0a 20 20 20 20 3b 20 73 69 6c 65 6e ))).. ; silen
5930: 63 65 20 77 61 72 6e 69 6e 67 73 20 6f 66 20 73 ce warnings of s
5940: 6f 6d 65 20 6d 61 63 72 6f 20 65 78 70 61 6e 64 ome macro expand
5950: 65 72 73 0a 20 20 20 20 28 28 3a 67 65 6e 65 72 ers. ((:gener
5960: 61 74 6f 72 2d 70 72 6f 63 20 76 61 72 29 0a 20 ator-proc var).
5970: 20 20 20 20 28 65 72 72 6f 72 20 22 69 6c 6c 65 (error "ille
5980: 67 61 6c 20 6d 61 63 72 6f 20 63 61 6c 6c 22 29 gal macro call")
5990: 20 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 )))...(define (
59a0: 64 69 73 70 61 74 63 68 2d 75 6e 69 6f 6e 20 64 dispatch-union d
59b0: 31 20 64 32 29 0a 20 20 28 6c 61 6d 62 64 61 20 1 d2). (lambda
59c0: 28 61 72 67 73 29 0a 20 20 20 20 28 6c 65 74 20 (args). (let
59d0: 28 28 67 31 20 28 64 31 20 61 72 67 73 29 29 20 ((g1 (d1 args))
59e0: 28 67 32 20 28 64 32 20 61 72 67 73 29 29 29 0a (g2 (d2 args))).
59f0: 20 20 20 20 20 20 28 69 66 20 67 31 0a 20 20 20 (if g1.
5a00: 20 20 20 20 20 20 20 28 69 66 20 67 32 20 0a 20 (if g2 .
5a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
5a20: 20 28 6e 75 6c 6c 3f 20 61 72 67 73 29 0a 20 20 (null? args).
5a30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a40: 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 73 (append (if (lis
5a50: 74 3f 20 67 31 29 20 67 31 20 28 6c 69 73 74 20 t? g1) g1 (list
5a60: 67 31 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 g1)) .
5a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a80: 28 69 66 20 28 6c 69 73 74 3f 20 67 32 29 20 67 (if (list? g2) g
5a90: 32 20 28 6c 69 73 74 20 67 32 29 29 20 29 0a 20 2 (list g2)) ).
5aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ab0: 20 28 65 72 72 6f 72 20 22 64 69 73 70 61 74 63 (error "dispatc
5ac0: 68 69 6e 67 20 63 6f 6e 66 6c 69 63 74 22 20 61 hing conflict" a
5ad0: 72 67 73 20 28 64 31 20 27 28 29 29 20 28 64 32 rgs (d1 '()) (d2
5ae0: 20 27 28 29 29 29 20 29 0a 20 20 20 20 20 20 20 '())) ).
5af0: 20 20 20 20 20 20 20 67 31 20 29 0a 20 20 20 20 g1 ).
5b00: 20 20 20 20 20 20 28 69 66 20 67 32 20 67 32 20 (if g2 g2
5b10: 23 66 29 20 29 29 29 29 0a 0a 0a 3b 20 3d 3d 3d #f) ))))...; ===
5b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b60: 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 64 69 =======.; The di
5b70: 73 70 61 74 63 68 69 6e 67 20 67 65 6e 65 72 61 spatching genera
5b80: 74 6f 72 20 3a 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d tor :.; ========
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bd0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ==..(define (mak
5be0: 65 2d 69 6e 69 74 69 61 6c 2d 3a 2d 64 69 73 70 e-initial-:-disp
5bf0: 61 74 63 68 29 0a 20 20 28 6c 61 6d 62 64 61 20 atch). (lambda
5c00: 28 61 72 67 73 29 0a 20 20 20 20 28 63 61 73 65 (args). (case
5c10: 20 28 6c 65 6e 67 74 68 20 61 72 67 73 29 0a 20 (length args).
5c20: 20 20 20 20 20 28 28 30 29 20 27 53 52 46 49 34 ((0) 'SRFI4
5c30: 32 29 0a 20 20 20 20 20 20 28 28 31 29 20 28 6c 2). ((1) (l
5c40: 65 74 20 28 28 61 31 20 28 63 61 72 20 61 72 67 et ((a1 (car arg
5c50: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s))).
5c60: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
5c70: 20 20 20 20 20 20 28 28 6c 69 73 74 3f 20 61 31 ((list? a1
5c80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5c90: 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f (:generator-pro
5ca0: 63 20 28 3a 6c 69 73 74 20 61 31 29 29 20 29 0a c (:list a1)) ).
5cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
5cc0: 73 74 72 69 6e 67 3f 20 61 31 29 0a 20 20 20 20 string? a1).
5cd0: 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 65 6e (:gen
5ce0: 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a 73 74 erator-proc (:st
5cf0: 72 69 6e 67 20 61 31 29 29 20 29 0a 20 20 20 20 ring a1)) ).
5d00: 20 20 20 20 20 20 20 20 20 20 28 28 76 65 63 74 ((vect
5d10: 6f 72 3f 20 61 31 29 0a 20 20 20 20 20 20 20 20 or? a1).
5d20: 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 (:generat
5d30: 6f 72 2d 70 72 6f 63 20 28 3a 76 65 63 74 6f 72 or-proc (:vector
5d40: 20 61 31 29 29 20 29 0a 20 20 20 20 20 20 20 20 a1)) ).
5d50: 20 20 20 20 20 20 28 28 61 6e 64 20 28 69 6e 74 ((and (int
5d60: 65 67 65 72 3f 20 61 31 29 20 28 65 78 61 63 74 eger? a1) (exact
5d70: 3f 20 61 31 29 29 0a 20 20 20 20 20 20 20 20 20 ? a1)).
5d80: 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 6f (:generato
5d90: 72 2d 70 72 6f 63 20 28 3a 72 61 6e 67 65 20 61 r-proc (:range a
5da0: 31 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 1)) ).
5db0: 20 20 20 20 28 28 72 65 61 6c 3f 20 61 31 29 0a ((real? a1).
5dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5dd0: 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 :generator-proc
5de0: 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 61 31 29 (:real-range a1)
5df0: 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ) ).
5e00: 20 20 28 28 69 6e 70 75 74 2d 70 6f 72 74 3f 20 ((input-port?
5e10: 61 31 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 a1).
5e20: 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 (:generator-p
5e30: 72 6f 63 20 28 3a 70 6f 72 74 20 61 31 29 29 20 roc (:port a1))
5e40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5e50: 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 (else.
5e60: 20 20 20 20 20 23 66 20 29 29 29 29 0a 20 20 20 #f )))).
5e70: 20 20 20 28 28 32 29 20 28 6c 65 74 20 28 28 61 ((2) (let ((a
5e80: 31 20 28 63 61 72 20 61 72 67 73 29 29 20 28 61 1 (car args)) (a
5e90: 32 20 28 63 61 64 72 20 61 72 67 73 29 29 29 0a 2 (cadr args))).
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
5eb0: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nd.
5ec0: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 61 31 ((and (list? a1
5ed0: 29 20 28 6c 69 73 74 3f 20 61 32 29 29 0a 20 20 ) (list? a2)).
5ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 (:g
5ef0: 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a enerator-proc (:
5f00: 6c 69 73 74 20 61 31 20 61 32 29 29 20 29 0a 20 list a1 a2)) ).
5f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
5f20: 6e 64 20 28 73 74 72 69 6e 67 3f 20 61 31 29 20 nd (string? a1)
5f30: 28 73 74 72 69 6e 67 3f 20 61 32 29 29 0a 20 20 (string? a2)).
5f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 (:g
5f50: 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a enerator-proc (:
5f60: 73 74 72 69 6e 67 20 61 31 20 61 32 29 29 20 29 string a1 a2)) )
5f70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
5f80: 28 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 61 31 (and (vector? a1
5f90: 29 20 28 76 65 63 74 6f 72 3f 20 61 32 29 29 0a ) (vector? a2)).
5fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5fb0: 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 :generator-proc
5fc0: 28 3a 76 65 63 74 6f 72 20 61 31 20 61 32 29 29 (:vector a1 a2))
5fd0: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5fe0: 20 28 28 61 6e 64 20 28 69 6e 74 65 67 65 72 3f ((and (integer?
5ff0: 20 61 31 29 20 28 65 78 61 63 74 3f 20 61 31 29 a1) (exact? a1)
6000: 20 28 69 6e 74 65 67 65 72 3f 20 61 32 29 20 28 (integer? a2) (
6010: 65 78 61 63 74 3f 20 61 32 29 29 0a 20 20 20 20 exact? a2)).
6020: 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 65 6e (:gen
6030: 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a 72 61 erator-proc (:ra
6040: 6e 67 65 20 61 31 20 61 32 29 29 20 29 0a 20 20 nge a1 a2)) ).
6050: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e ((an
6060: 64 20 28 72 65 61 6c 3f 20 61 31 29 20 28 72 65 d (real? a1) (re
6070: 61 6c 3f 20 61 32 29 29 0a 20 20 20 20 20 20 20 al? a2)).
6080: 20 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 (:genera
6090: 74 6f 72 2d 70 72 6f 63 20 28 3a 72 65 61 6c 2d tor-proc (:real-
60a0: 72 61 6e 67 65 20 61 31 20 61 32 29 29 20 29 0a range a1 a2)) ).
60b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
60c0: 61 6e 64 20 28 63 68 61 72 3f 20 61 31 29 20 28 and (char? a1) (
60d0: 63 68 61 72 3f 20 61 32 29 29 0a 20 20 20 20 20 char? a2)).
60e0: 20 20 20 20 20 20 20 20 20 20 28 3a 67 65 6e 65 (:gene
60f0: 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a 63 68 61 rator-proc (:cha
6100: 72 2d 72 61 6e 67 65 20 61 31 20 61 32 29 29 20 r-range a1 a2))
6110: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6120: 28 28 61 6e 64 20 28 69 6e 70 75 74 2d 70 6f 72 ((and (input-por
6130: 74 3f 20 61 31 29 20 28 70 72 6f 63 65 64 75 72 t? a1) (procedur
6140: 65 3f 20 61 32 29 29 0a 20 20 20 20 20 20 20 20 e? a2)).
6150: 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 (:generat
6160: 6f 72 2d 70 72 6f 63 20 28 3a 70 6f 72 74 20 61 or-proc (:port a
6170: 31 20 61 32 29 29 20 29 0a 20 20 20 20 20 20 20 1 a2)) ).
6180: 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 (else.
6190: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 20 29 #f )
61a0: 29 29 29 0a 20 20 20 20 20 20 28 28 33 29 20 28 ))). ((3) (
61b0: 6c 65 74 20 28 28 61 31 20 28 63 61 72 20 61 72 let ((a1 (car ar
61c0: 67 73 29 29 20 28 61 32 20 28 63 61 64 72 20 61 gs)) (a2 (cadr a
61d0: 72 67 73 29 29 20 28 61 33 20 28 63 61 64 64 72 rgs)) (a3 (caddr
61e0: 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 20 20 args))).
61f0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond.
6200: 20 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 ((and
6210: 28 6c 69 73 74 3f 20 61 31 29 20 28 6c 69 73 74 (list? a1) (list
6220: 3f 20 61 32 29 20 28 6c 69 73 74 3f 20 61 33 29 ? a2) (list? a3)
6230: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6240: 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f (:generator-pro
6250: 63 20 28 3a 6c 69 73 74 20 61 31 20 61 32 20 61 c (:list a1 a2 a
6260: 33 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 3)) ).
6270: 20 20 20 20 28 28 61 6e 64 20 28 73 74 72 69 6e ((and (strin
6280: 67 3f 20 61 31 29 20 28 73 74 72 69 6e 67 3f 20 g? a1) (string?
6290: 61 32 29 20 28 73 74 72 69 6e 67 3f 20 61 33 29 a2) (string? a3)
62a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
62b0: 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f (:generator-pro
62c0: 63 20 28 3a 73 74 72 69 6e 67 20 61 31 20 61 32 c (:string a1 a2
62d0: 20 61 33 29 29 20 29 0a 20 20 20 20 20 20 20 20 a3)) ).
62e0: 20 20 20 20 20 20 28 28 61 6e 64 20 28 76 65 63 ((and (vec
62f0: 74 6f 72 3f 20 61 31 29 20 28 76 65 63 74 6f 72 tor? a1) (vector
6300: 3f 20 61 32 29 20 28 76 65 63 74 6f 72 3f 20 61 ? a2) (vector? a
6310: 33 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 3)).
6320: 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 (:generator-p
6330: 72 6f 63 20 28 3a 76 65 63 74 6f 72 20 61 31 20 roc (:vector a1
6340: 61 32 20 61 33 29 29 20 29 0a 20 20 20 20 20 20 a2 a3)) ).
6350: 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 69 ((and (i
6360: 6e 74 65 67 65 72 3f 20 61 31 29 20 28 65 78 61 nteger? a1) (exa
6370: 63 74 3f 20 61 31 29 20 0a 20 20 20 20 20 20 20 ct? a1) .
6380: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 6e (in
6390: 74 65 67 65 72 3f 20 61 32 29 20 28 65 78 61 63 teger? a2) (exac
63a0: 74 3f 20 61 32 29 0a 20 20 20 20 20 20 20 20 20 t? a2).
63b0: 20 20 20 20 20 20 20 20 20 20 20 28 69 6e 74 65 (inte
63c0: 67 65 72 3f 20 61 33 29 20 28 65 78 61 63 74 3f ger? a3) (exact?
63d0: 20 61 33 29 29 0a 20 20 20 20 20 20 20 20 20 20 a3)).
63e0: 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 (:generator
63f0: 2d 70 72 6f 63 20 28 3a 72 61 6e 67 65 20 61 31 -proc (:range a1
6400: 20 61 32 20 61 33 29 29 20 29 0a 20 20 20 20 20 a2 a3)) ).
6410: 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 ((and (
6420: 72 65 61 6c 3f 20 61 31 29 20 28 72 65 61 6c 3f real? a1) (real?
6430: 20 61 32 29 20 28 72 65 61 6c 3f 20 61 33 29 29 a2) (real? a3))
6440: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6450: 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 (:generator-proc
6460: 20 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 61 31 (:real-range a1
6470: 20 61 32 20 61 33 29 29 20 29 0a 20 20 20 20 20 a2 a3)) ).
6480: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 (else.
6490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 #f
64a0: 20 29 29 29 29 0a 20 20 20 20 20 20 28 65 6c 73 )))). (els
64b0: 65 0a 20 20 20 20 20 20 20 28 6c 65 74 72 65 63 e. (letrec
64c0: 20 28 28 65 76 65 72 79 3f 20 0a 20 20 20 20 20 ((every? .
64d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
64e0: 62 64 61 20 28 70 72 65 64 20 61 72 67 73 29 0a bda (pred args).
64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6500: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 (if (null? ar
6510: 67 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 gs).
6520: 20 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 #t.
6530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6540: 20 20 20 20 20 28 61 6e 64 20 28 70 72 65 64 20 (and (pred
6550: 28 63 61 72 20 61 72 67 73 29 29 0a 20 20 20 20 (car args)).
6560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6570: 20 20 20 20 20 20 20 20 28 65 76 65 72 79 3f 20 (every?
6580: 70 72 65 64 20 28 63 64 72 20 61 72 67 73 29 29 pred (cdr args))
6590: 20 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 ))))).
65a0: 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 (cond.
65b0: 28 28 65 76 65 72 79 3f 20 6c 69 73 74 3f 20 61 ((every? list? a
65c0: 72 67 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 rgs).
65d0: 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 (:generator-proc
65e0: 20 28 3a 6c 69 73 74 20 28 61 70 70 6c 79 20 61 (:list (apply a
65f0: 70 70 65 6e 64 20 61 72 67 73 29 29 29 20 29 0a ppend args))) ).
6600: 20 20 20 20 20 20 20 20 20 20 28 28 65 76 65 72 ((ever
6610: 79 3f 20 73 74 72 69 6e 67 3f 20 61 72 67 73 29 y? string? args)
6620: 0a 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 65 . (:ge
6630: 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a 73 nerator-proc (:s
6640: 74 72 69 6e 67 20 28 61 70 70 6c 79 20 73 74 72 tring (apply str
6650: 69 6e 67 2d 61 70 70 65 6e 64 20 61 72 67 73 29 ing-append args)
6660: 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 28 )) ). (
6670: 28 65 76 65 72 79 3f 20 76 65 63 74 6f 72 3f 20 (every? vector?
6680: 61 72 67 73 29 0a 20 20 20 20 20 20 20 20 20 20 args).
6690: 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f (:generator-pro
66a0: 63 20 28 3a 6c 69 73 74 20 28 61 70 70 6c 79 20 c (:list (apply
66b0: 61 70 70 65 6e 64 20 28 6d 61 70 20 76 65 63 74 append (map vect
66c0: 6f 72 2d 3e 6c 69 73 74 20 61 72 67 73 29 29 29 or->list args)))
66d0: 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 28 65 ) ). (e
66e0: 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 23 lse. #
66f0: 66 20 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 f )))))))..(defi
6700: 6e 65 20 3a 2d 64 69 73 70 61 74 63 68 20 0a 20 ne :-dispatch .
6710: 20 28 6d 61 6b 65 2d 70 61 72 61 6d 65 74 65 72 (make-parameter
6720: 20 28 6d 61 6b 65 2d 69 6e 69 74 69 61 6c 2d 3a (make-initial-:
6730: 2d 64 69 73 70 61 74 63 68 29 0a 20 20 20 20 20 -dispatch).
6740: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
6750: 6d 62 64 61 20 28 78 29 20 28 69 66 20 28 70 72 mbda (x) (if (pr
6760: 6f 63 65 64 75 72 65 3f 20 78 29 20 78 20 28 65 ocedure? x) x (e
6770: 72 72 6f 72 20 22 6e 6f 74 20 61 20 70 72 6f 63 rror "not a proc
6780: 65 64 75 72 65 22 20 78 29 29 29 29 29 0a 0a 28 edure" x)))))..(
6790: 64 65 66 69 6e 65 20 28 3a 2d 64 69 73 70 61 74 define (:-dispat
67a0: 63 68 2d 72 65 66 29 0a 20 20 28 3a 2d 64 69 73 ch-ref). (:-dis
67b0: 70 61 74 63 68 29 29 0a 0a 28 64 65 66 69 6e 65 patch))..(define
67c0: 20 28 3a 2d 64 69 73 70 61 74 63 68 2d 73 65 74 (:-dispatch-set
67d0: 21 20 64 69 73 70 61 74 63 68 29 0a 20 20 28 3a ! dispatch). (:
67e0: 2d 64 69 73 70 61 74 63 68 20 64 69 73 70 61 74 -dispatch dispat
67f0: 63 68 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ch))..(define-sy
6800: 6e 74 61 78 20 3a 0a 20 20 28 73 79 6e 74 61 78 ntax :. (syntax
6810: 2d 72 75 6c 65 73 20 28 69 6e 64 65 78 29 0a 20 -rules (index).
6820: 20 20 20 28 28 3a 20 63 63 20 76 61 72 20 28 69 ((: cc var (i
6830: 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 72 67 ndex i) arg1 arg
6840: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 64 69 73 ...). (:dis
6850: 70 61 74 63 68 65 64 20 63 63 20 76 61 72 20 28 patched cc var (
6860: 69 6e 64 65 78 20 69 29 20 28 3a 2d 64 69 73 70 index i) (:-disp
6870: 61 74 63 68 29 20 61 72 67 31 20 61 72 67 20 2e atch) arg1 arg .
6880: 2e 2e 29 20 29 0a 20 20 20 20 28 28 3a 20 63 63 ..) ). ((: cc
6890: 20 76 61 72 20 61 72 67 31 20 61 72 67 20 2e 2e var arg1 arg ..
68a0: 2e 29 0a 20 20 20 20 20 28 3a 64 69 73 70 61 74 .). (:dispat
68b0: 63 68 65 64 20 63 63 20 76 61 72 20 28 3a 2d 64 ched cc var (:-d
68c0: 69 73 70 61 74 63 68 29 20 61 72 67 31 20 61 72 ispatch) arg1 ar
68d0: 67 20 2e 2e 2e 29 20 29 29 29 0a 0a 0a 3b 20 3d g ...) )))...; =
68e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 =========.; The
6930: 75 74 69 6c 69 74 79 20 63 6f 6d 70 72 65 68 65 utility comprehe
6940: 6e 73 69 6f 6e 73 20 66 6f 6c 64 2d 65 63 2c 20 nsions fold-ec,
6950: 66 6f 6c 64 33 2d 65 63 0a 3b 20 3d 3d 3d 3d 3d fold3-ec.; =====
6960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69a0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d 73 =====..(define-s
69b0: 79 6e 74 61 78 20 66 6f 6c 64 33 2d 65 63 0a 20 yntax fold3-ec.
69c0: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
69d0: 6e 65 73 74 65 64 29 0a 20 20 20 20 28 28 66 6f nested). ((fo
69e0: 6c 64 33 2d 65 63 20 78 30 20 28 6e 65 73 74 65 ld3-ec x0 (neste
69f0: 64 20 71 31 20 2e 2e 2e 29 20 71 20 65 74 63 31 d q1 ...) q etc1
6a00: 20 65 74 63 32 20 65 74 63 33 20 65 74 63 20 2e etc2 etc3 etc .
6a10: 2e 2e 29 0a 20 20 20 20 20 28 66 6f 6c 64 33 2d ..). (fold3-
6a20: 65 63 20 78 30 20 28 6e 65 73 74 65 64 20 71 31 ec x0 (nested q1
6a30: 20 2e 2e 2e 20 71 29 20 65 74 63 31 20 65 74 63 ... q) etc1 etc
6a40: 32 20 65 74 63 33 20 65 74 63 20 2e 2e 2e 29 20 2 etc3 etc ...)
6a50: 29 0a 20 20 20 20 28 28 66 6f 6c 64 33 2d 65 63 ). ((fold3-ec
6a60: 20 78 30 20 71 31 20 71 32 20 65 74 63 31 20 65 x0 q1 q2 etc1 e
6a70: 74 63 32 20 65 74 63 33 20 65 74 63 20 2e 2e 2e tc2 etc3 etc ...
6a80: 29 0a 20 20 20 20 20 28 66 6f 6c 64 33 2d 65 63 ). (fold3-ec
6a90: 20 78 30 20 28 6e 65 73 74 65 64 20 71 31 20 71 x0 (nested q1 q
6aa0: 32 29 20 65 74 63 31 20 65 74 63 32 20 65 74 63 2) etc1 etc2 etc
6ab0: 33 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 20 3 etc ...) ).
6ac0: 20 28 28 66 6f 6c 64 33 2d 65 63 20 78 30 20 65 ((fold3-ec x0 e
6ad0: 78 70 72 65 73 73 69 6f 6e 20 66 31 20 66 32 29 xpression f1 f2)
6ae0: 0a 20 20 20 20 20 28 66 6f 6c 64 33 2d 65 63 20 . (fold3-ec
6af0: 78 30 20 28 6e 65 73 74 65 64 29 20 65 78 70 72 x0 (nested) expr
6b00: 65 73 73 69 6f 6e 20 66 31 20 66 32 29 20 29 0a ession f1 f2) ).
6b10: 0a 20 20 20 20 28 28 66 6f 6c 64 33 2d 65 63 20 . ((fold3-ec
6b20: 78 30 20 71 75 61 6c 69 66 69 65 72 20 65 78 70 x0 qualifier exp
6b30: 72 65 73 73 69 6f 6e 20 66 31 20 66 32 29 0a 20 ression f1 f2).
6b40: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c (let ((resul
6b50: 74 20 23 66 29 20 28 65 6d 70 74 79 20 23 74 29 t #f) (empty #t)
6b60: 29 0a 20 20 20 20 20 20 20 28 64 6f 2d 65 63 20 ). (do-ec
6b70: 71 75 61 6c 69 66 69 65 72 0a 20 20 20 20 20 20 qualifier.
6b80: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 (let ((v
6b90: 61 6c 75 65 20 65 78 70 72 65 73 73 69 6f 6e 29 alue expression)
6ba0: 29 20 3b 20 64 6f 6e 27 74 20 64 75 70 6c 69 63 ) ; don't duplic
6bb0: 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ate.
6bc0: 20 20 20 20 28 69 66 20 65 6d 70 74 79 0a 20 20 (if empty.
6bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6be0: 20 20 28 62 65 67 69 6e 20 28 73 65 74 21 20 72 (begin (set! r
6bf0: 65 73 75 6c 74 20 28 66 31 20 76 61 6c 75 65 29 esult (f1 value)
6c00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 (se
6c20: 74 21 20 65 6d 70 74 79 20 23 66 29 20 29 0a 20 t! empty #f) ).
6c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c40: 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
6c50: 28 66 32 20 76 61 6c 75 65 20 72 65 73 75 6c 74 (f2 value result
6c60: 29 29 20 29 29 29 0a 20 20 20 20 20 20 20 28 69 )) ))). (i
6c70: 66 20 65 6d 70 74 79 20 78 30 20 72 65 73 75 6c f empty x0 resul
6c80: 74 29 20 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e t) ))))...(defin
6c90: 65 2d 73 79 6e 74 61 78 20 66 6f 6c 64 2d 65 63 e-syntax fold-ec
6ca0: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
6cb0: 20 28 6e 65 73 74 65 64 29 0a 20 20 20 20 28 28 (nested). ((
6cc0: 66 6f 6c 64 2d 65 63 20 78 30 20 28 6e 65 73 74 fold-ec x0 (nest
6cd0: 65 64 20 71 31 20 2e 2e 2e 29 20 71 20 65 74 63 ed q1 ...) q etc
6ce0: 31 20 65 74 63 32 20 65 74 63 20 2e 2e 2e 29 0a 1 etc2 etc ...).
6cf0: 20 20 20 20 20 28 66 6f 6c 64 2d 65 63 20 78 30 (fold-ec x0
6d00: 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 20 (nested q1 ...
6d10: 71 29 20 65 74 63 31 20 65 74 63 32 20 65 74 63 q) etc1 etc2 etc
6d20: 20 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 66 6f ...) ). ((fo
6d30: 6c 64 2d 65 63 20 78 30 20 71 31 20 71 32 20 65 ld-ec x0 q1 q2 e
6d40: 74 63 31 20 65 74 63 32 20 65 74 63 20 2e 2e 2e tc1 etc2 etc ...
6d50: 29 0a 20 20 20 20 20 28 66 6f 6c 64 2d 65 63 20 ). (fold-ec
6d60: 78 30 20 28 6e 65 73 74 65 64 20 71 31 20 71 32 x0 (nested q1 q2
6d70: 29 20 65 74 63 31 20 65 74 63 32 20 65 74 63 20 ) etc1 etc2 etc
6d80: 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 66 6f 6c ...) ). ((fol
6d90: 64 2d 65 63 20 78 30 20 65 78 70 72 65 73 73 69 d-ec x0 expressi
6da0: 6f 6e 20 66 32 29 0a 20 20 20 20 20 28 66 6f 6c on f2). (fol
6db0: 64 2d 65 63 20 78 30 20 28 6e 65 73 74 65 64 29 d-ec x0 (nested)
6dc0: 20 65 78 70 72 65 73 73 69 6f 6e 20 66 32 29 20 expression f2)
6dd0: 29 0a 0a 20 20 20 20 28 28 66 6f 6c 64 2d 65 63 ).. ((fold-ec
6de0: 20 78 30 20 71 75 61 6c 69 66 69 65 72 20 65 78 x0 qualifier ex
6df0: 70 72 65 73 73 69 6f 6e 20 66 32 29 0a 20 20 20 pression f2).
6e00: 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 (let ((result
6e10: 78 30 29 29 0a 20 20 20 20 20 20 20 28 64 6f 2d x0)). (do-
6e20: 65 63 20 71 75 61 6c 69 66 69 65 72 20 28 73 65 ec qualifier (se
6e30: 74 21 20 72 65 73 75 6c 74 20 28 66 32 20 65 78 t! result (f2 ex
6e40: 70 72 65 73 73 69 6f 6e 20 72 65 73 75 6c 74 29 pression result)
6e50: 29 29 0a 20 20 20 20 20 20 20 72 65 73 75 6c 74 )). result
6e60: 20 29 29 29 29 0a 0a 0a 3b 20 3d 3d 3d 3d 3d 3d ))))...; ======
6e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6eb0: 3d 3d 3d 3d 0a 3b 20 54 68 65 20 63 6f 6d 70 72 ====.; The compr
6ec0: 65 68 65 6e 73 69 6f 6e 73 20 6c 69 73 74 2d 65 ehensions list-e
6ed0: 63 20 73 74 72 69 6e 67 2d 65 63 20 76 65 63 74 c string-ec vect
6ee0: 6f 72 2d 65 63 20 65 74 63 2e 0a 3b 20 3d 3d 3d or-ec etc..; ===
6ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f30: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
6f40: 2d 73 79 6e 74 61 78 20 6c 69 73 74 2d 65 63 0a -syntax list-ec.
6f50: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
6f60: 28 29 0a 20 20 20 20 28 28 6c 69 73 74 2d 65 63 (). ((list-ec
6f70: 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 etc1 etc ...).
6f80: 20 20 20 20 28 72 65 76 65 72 73 65 20 28 66 6f (reverse (fo
6f90: 6c 64 2d 65 63 20 27 28 29 20 65 74 63 31 20 65 ld-ec '() etc1 e
6fa0: 74 63 20 2e 2e 2e 20 63 6f 6e 73 29 29 20 29 29 tc ... cons)) ))
6fb0: 29 0a 0a 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 )..; Alternative
6fc0: 3a 20 52 65 76 65 72 73 65 20 63 61 6e 20 73 61 : Reverse can sa
6fd0: 66 65 6c 79 20 62 65 20 72 65 70 6c 61 63 65 64 fely be replaced
6fe0: 20 62 79 20 72 65 76 65 72 73 65 21 20 69 66 20 by reverse! if
6ff0: 79 6f 75 20 68 61 76 65 20 69 74 2e 0a 3b 0a 3b you have it..;.;
7000: 20 41 6c 74 65 72 6e 61 74 69 76 65 3a 20 49 74 Alternative: It
7010: 20 69 73 20 70 6f 73 73 69 62 6c 65 20 74 6f 20 is possible to
7020: 63 6f 6e 73 74 72 75 63 74 20 74 68 65 20 72 65 construct the re
7030: 73 75 6c 74 20 69 6e 20 74 68 65 20 63 6f 72 72 sult in the corr
7040: 65 63 74 20 6f 72 64 65 72 0a 3b 20 20 20 75 73 ect order.; us
7050: 69 6e 67 20 73 65 74 2d 63 64 72 21 20 74 6f 20 ing set-cdr! to
7060: 61 64 64 20 61 74 20 74 68 65 20 74 61 69 6c 2e add at the tail.
7070: 20 54 68 69 73 20 72 65 6d 6f 76 65 73 20 74 68 This removes th
7080: 65 20 6f 76 65 72 68 65 61 64 20 6f 66 20 63 6f e overhead of co
7090: 70 79 69 6e 67 0a 3b 20 20 20 61 74 20 74 68 65 pying.; at the
70a0: 20 65 6e 64 2c 20 61 74 20 74 68 65 20 63 6f 73 end, at the cos
70b0: 74 20 6f 66 20 6d 6f 72 65 20 62 6f 6f 6b 2d 6b t of more book-k
70c0: 65 65 70 69 6e 67 2e 0a 0a 0a 28 64 65 66 69 6e eeping....(defin
70d0: 65 2d 73 79 6e 74 61 78 20 61 70 70 65 6e 64 2d e-syntax append-
70e0: 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c ec. (syntax-rul
70f0: 65 73 20 28 29 0a 20 20 20 20 28 28 61 70 70 65 es (). ((appe
7100: 6e 64 2d 65 63 20 65 74 63 31 20 65 74 63 20 2e nd-ec etc1 etc .
7110: 2e 2e 29 0a 20 20 20 20 20 28 61 70 70 6c 79 20 ..). (apply
7120: 61 70 70 65 6e 64 20 28 6c 69 73 74 2d 65 63 20 append (list-ec
7130: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 29 20 29 etc1 etc ...)) )
7140: 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ))..(define-synt
7150: 61 78 20 73 74 72 69 6e 67 2d 65 63 0a 20 20 28 ax string-ec. (
7160: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules ().
7170: 20 20 20 20 28 28 73 74 72 69 6e 67 2d 65 63 20 ((string-ec
7180: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 etc1 etc ...).
7190: 20 20 20 28 6c 69 73 74 2d 3e 73 74 72 69 6e 67 (list->string
71a0: 20 28 6c 69 73 74 2d 65 63 20 65 74 63 31 20 65 (list-ec etc1 e
71b0: 74 63 20 2e 2e 2e 29 29 20 29 29 29 0a 0a 3b 20 tc ...)) )))..;
71c0: 41 6c 74 65 72 6e 61 74 69 76 65 3a 20 46 6f 72 Alternative: For
71d0: 20 76 65 72 79 20 6c 6f 6e 67 20 73 74 72 69 6e very long strin
71e0: 67 73 2c 20 74 68 65 20 69 6e 74 65 72 6d 65 64 gs, the intermed
71f0: 69 61 74 65 20 6c 69 73 74 20 6d 61 79 20 62 65 iate list may be
7200: 20 61 0a 3b 20 20 20 70 72 6f 62 6c 65 6d 2e 20 a.; problem.
7210: 41 20 6d 6f 72 65 20 73 70 61 63 65 2d 61 77 61 A more space-awa
7220: 72 65 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f re implementatio
7230: 6e 20 63 6f 6c 6c 65 63 74 20 74 68 65 20 63 68 n collect the ch
7240: 61 72 61 63 74 65 72 73 20 0a 3b 20 20 20 69 6e aracters .; in
7250: 20 61 6e 20 69 6e 74 65 72 6d 65 64 69 61 74 65 an intermediate
7260: 20 6c 69 73 74 20 61 6e 64 20 77 68 65 6e 20 74 list and when t
7270: 68 69 73 20 6c 69 73 74 20 62 65 63 6f 6d 65 73 his list becomes
7280: 20 74 6f 6f 20 6c 61 72 67 65 20 69 74 20 69 73 too large it is
7290: 0a 3b 20 20 20 63 6f 6e 76 65 72 74 65 64 20 69 .; converted i
72a0: 6e 74 6f 20 61 6e 20 69 6e 74 65 72 6d 65 64 69 nto an intermedi
72b0: 61 74 65 20 73 74 72 69 6e 67 2e 20 41 74 20 74 ate string. At t
72c0: 68 65 20 65 6e 64 2c 20 74 68 65 20 69 6e 74 65 he end, the inte
72d0: 72 6d 65 64 69 61 74 65 0a 3b 20 20 20 73 74 72 rmediate.; str
72e0: 69 6e 67 73 20 61 72 65 20 63 6f 6e 63 61 74 65 ings are concate
72f0: 6e 61 74 65 64 20 77 69 74 68 20 73 74 72 69 6e nated with strin
7300: 67 2d 61 70 70 65 6e 64 2e 0a 0a 0a 28 64 65 66 g-append....(def
7310: 69 6e 65 2d 73 79 6e 74 61 78 20 73 74 72 69 6e ine-syntax strin
7320: 67 2d 61 70 70 65 6e 64 2d 65 63 0a 20 20 28 73 g-append-ec. (s
7330: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
7340: 20 20 20 28 28 73 74 72 69 6e 67 2d 61 70 70 65 ((string-appe
7350: 6e 64 2d 65 63 20 65 74 63 31 20 65 74 63 20 2e nd-ec etc1 etc .
7360: 2e 2e 29 0a 20 20 20 20 20 28 61 70 70 6c 79 20 ..). (apply
7370: 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 20 28 6c string-append (l
7380: 69 73 74 2d 65 63 20 65 74 63 31 20 65 74 63 20 ist-ec etc1 etc
7390: 2e 2e 2e 29 29 20 29 29 29 0a 0a 28 64 65 66 69 ...)) )))..(defi
73a0: 6e 65 2d 73 79 6e 74 61 78 20 76 65 63 74 6f 72 ne-syntax vector
73b0: 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 -ec. (syntax-ru
73c0: 6c 65 73 20 28 29 0a 20 20 20 20 28 28 76 65 63 les (). ((vec
73d0: 74 6f 72 2d 65 63 20 65 74 63 31 20 65 74 63 20 tor-ec etc1 etc
73e0: 2e 2e 2e 29 0a 20 20 20 20 20 28 6c 69 73 74 2d ...). (list-
73f0: 3e 76 65 63 74 6f 72 20 28 6c 69 73 74 2d 65 63 >vector (list-ec
7400: 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 29 20 etc1 etc ...))
7410: 29 29 29 0a 0a 3b 20 43 6f 6d 6d 65 6e 74 3a 20 )))..; Comment:
7420: 41 20 73 69 6d 69 6c 61 72 20 61 70 70 72 6f 61 A similar approa
7430: 63 68 20 61 73 20 66 6f 72 20 73 74 72 69 6e 67 ch as for string
7440: 2d 65 63 20 63 61 6e 20 62 65 20 75 73 65 64 20 -ec can be used
7450: 66 6f 72 20 76 65 63 74 6f 72 2d 65 63 2e 0a 3b for vector-ec..;
7460: 20 20 20 48 6f 77 65 76 65 72 2c 20 74 68 65 20 However, the
7470: 73 70 61 63 65 20 6f 76 65 72 68 65 61 64 20 66 space overhead f
7480: 6f 72 20 74 68 65 20 69 6e 74 65 72 6d 65 64 69 or the intermedi
7490: 61 74 65 20 6c 69 73 74 20 69 73 20 6d 75 63 68 ate list is much
74a0: 20 6c 6f 77 65 72 0a 3b 20 20 20 74 68 61 6e 20 lower.; than
74b0: 66 6f 72 20 73 74 72 69 6e 67 2d 65 63 20 61 6e for string-ec an
74c0: 64 20 61 73 20 74 68 65 72 65 20 69 73 20 6e 6f d as there is no
74d0: 20 76 65 63 74 6f 72 2d 61 70 70 65 6e 64 2c 20 vector-append,
74e0: 74 68 65 20 69 6e 74 65 72 6d 65 64 69 61 74 65 the intermediate
74f0: 0a 3b 20 20 20 76 65 63 74 6f 72 73 20 6d 75 73 .; vectors mus
7500: 74 20 62 65 20 63 6f 70 69 65 64 20 65 78 70 6c t be copied expl
7510: 69 63 69 74 6c 79 2e 0a 0a 28 64 65 66 69 6e 65 icitly...(define
7520: 2d 73 79 6e 74 61 78 20 76 65 63 74 6f 72 2d 6f -syntax vector-o
7530: 66 2d 6c 65 6e 67 74 68 2d 65 63 0a 20 20 28 73 f-length-ec. (s
7540: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 6e 65 73 yntax-rules (nes
7550: 74 65 64 29 0a 20 20 20 20 28 28 76 65 63 74 6f ted). ((vecto
7560: 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d 65 63 20 6b r-of-length-ec k
7570: 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 29 (nested q1 ...)
7580: 20 71 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 q etc1 etc ...)
7590: 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 6f 66 . (vector-of
75a0: 2d 6c 65 6e 67 74 68 2d 65 63 20 6b 20 28 6e 65 -length-ec k (ne
75b0: 73 74 65 64 20 71 31 20 2e 2e 2e 20 71 29 20 65 sted q1 ... q) e
75c0: 74 63 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 tc1 etc ...) ).
75d0: 20 20 20 28 28 76 65 63 74 6f 72 2d 6f 66 2d 6c ((vector-of-l
75e0: 65 6e 67 74 68 2d 65 63 20 6b 20 71 31 20 71 32 ength-ec k q1 q2
75f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 74 63 etc
7600: 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 1 etc ...).
7610: 28 76 65 63 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 (vector-of-lengt
7620: 68 2d 65 63 20 6b 20 28 6e 65 73 74 65 64 20 71 h-ec k (nested q
7630: 31 20 71 32 29 20 20 20 20 65 74 63 31 20 65 74 1 q2) etc1 et
7640: 63 20 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 76 c ...) ). ((v
7650: 65 63 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d ector-of-length-
7660: 65 63 20 6b 20 65 78 70 72 65 73 73 69 6f 6e 29 ec k expression)
7670: 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 6f 66 . (vector-of
7680: 2d 6c 65 6e 67 74 68 2d 65 63 20 6b 20 28 6e 65 -length-ec k (ne
7690: 73 74 65 64 29 20 65 78 70 72 65 73 73 69 6f 6e sted) expression
76a0: 29 20 29 0a 0a 20 20 20 20 28 28 76 65 63 74 6f ) ).. ((vecto
76b0: 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d 65 63 20 6b r-of-length-ec k
76c0: 20 71 75 61 6c 69 66 69 65 72 20 65 78 70 72 65 qualifier expre
76d0: 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 6c 65 74 ssion). (let
76e0: 20 28 28 6c 65 6e 20 6b 29 29 0a 20 20 20 20 20 ((len k)).
76f0: 20 20 28 6c 65 74 20 28 28 76 65 63 20 28 6d 61 (let ((vec (ma
7700: 6b 65 2d 76 65 63 74 6f 72 20 6c 65 6e 29 29 0a ke-vector len)).
7710: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 20 (i
7720: 30 29 20 29 0a 20 20 20 20 20 20 20 20 20 28 64 0) ). (d
7730: 6f 2d 65 63 20 71 75 61 6c 69 66 69 65 72 0a 20 o-ec qualifier.
7740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7750: 69 66 20 28 3c 20 69 20 6c 65 6e 29 0a 20 20 20 if (< i len).
7760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7770: 20 28 62 65 67 69 6e 20 28 76 65 63 74 6f 72 2d (begin (vector-
7780: 73 65 74 21 20 76 65 63 20 69 20 65 78 70 72 65 set! vec i expre
7790: 73 73 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 ssion).
77a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77b0: 20 20 28 73 65 74 21 20 69 20 28 2b 20 69 20 31 (set! i (+ i 1
77c0: 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 )) ).
77d0: 20 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 (error
77e0: 22 76 65 63 74 6f 72 20 69 73 20 74 6f 6f 20 73 "vector is too s
77f0: 68 6f 72 74 20 66 6f 72 20 74 68 65 20 63 6f 6d hort for the com
7800: 70 72 65 68 65 6e 73 69 6f 6e 22 29 20 29 29 0a prehension") )).
7810: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3d 20 (if (=
7820: 69 20 6c 65 6e 29 0a 20 20 20 20 20 20 20 20 20 i len).
7830: 20 20 20 20 76 65 63 0a 20 20 20 20 20 20 20 20 vec.
7840: 20 20 20 20 20 28 65 72 72 6f 72 20 22 76 65 63 (error "vec
7850: 74 6f 72 20 69 73 20 74 6f 6f 20 6c 6f 6e 67 20 tor is too long
7860: 66 6f 72 20 74 68 65 20 63 6f 6d 70 72 65 68 65 for the comprehe
7870: 6e 73 69 6f 6e 22 29 20 29 29 29 29 29 29 0a 0a nsion") ))))))..
7880: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax
7890: 73 75 6d 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 sum-ec. (syntax
78a0: 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 -rules (). ((
78b0: 73 75 6d 2d 65 63 20 65 74 63 31 20 65 74 63 20 sum-ec etc1 etc
78c0: 2e 2e 2e 29 0a 20 20 20 20 20 28 66 6f 6c 64 2d ...). (fold-
78d0: 65 63 20 28 2b 29 20 65 74 63 31 20 65 74 63 20 ec (+) etc1 etc
78e0: 2e 2e 2e 20 2b 29 20 29 29 29 0a 0a 28 64 65 66 ... +) )))..(def
78f0: 69 6e 65 2d 73 79 6e 74 61 78 20 70 72 6f 64 75 ine-syntax produ
7900: 63 74 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d ct-ec. (syntax-
7910: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 70 rules (). ((p
7920: 72 6f 64 75 63 74 2d 65 63 20 65 74 63 31 20 65 roduct-ec etc1 e
7930: 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 66 6f tc ...). (fo
7940: 6c 64 2d 65 63 20 28 2a 29 20 65 74 63 31 20 65 ld-ec (*) etc1 e
7950: 74 63 20 2e 2e 2e 20 2a 29 20 29 29 29 0a 0a 28 tc ... *) )))..(
7960: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 6d 69 define-syntax mi
7970: 6e 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 n-ec. (syntax-r
7980: 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 6d 69 ules (). ((mi
7990: 6e 2d 65 63 20 65 74 63 31 20 65 74 63 20 2e 2e n-ec etc1 etc ..
79a0: 2e 29 0a 20 20 20 20 20 28 66 6f 6c 64 33 2d 65 .). (fold3-e
79b0: 63 20 28 6d 69 6e 29 20 65 74 63 31 20 65 74 63 c (min) etc1 etc
79c0: 20 2e 2e 2e 20 6d 69 6e 20 6d 69 6e 29 20 29 29 ... min min) ))
79d0: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta
79e0: 78 20 6d 61 78 2d 65 63 0a 20 20 28 73 79 6e 74 x max-ec. (synt
79f0: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
7a00: 28 28 6d 61 78 2d 65 63 20 65 74 63 31 20 65 74 ((max-ec etc1 et
7a10: 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 66 6f 6c c ...). (fol
7a20: 64 33 2d 65 63 20 28 6d 61 78 29 20 65 74 63 31 d3-ec (max) etc1
7a30: 20 65 74 63 20 2e 2e 2e 20 6d 61 78 20 6d 61 78 etc ... max max
7a40: 29 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 ) )))..(define-s
7a50: 79 6e 74 61 78 20 6c 61 73 74 2d 65 63 0a 20 20 yntax last-ec.
7a60: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 6e (syntax-rules (n
7a70: 65 73 74 65 64 29 0a 20 20 20 20 28 28 6c 61 73 ested). ((las
7a80: 74 2d 65 63 20 64 65 66 61 75 6c 74 20 28 6e 65 t-ec default (ne
7a90: 73 74 65 64 20 71 31 20 2e 2e 2e 29 20 71 20 65 sted q1 ...) q e
7aa0: 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 tc1 etc ...).
7ab0: 20 20 28 6c 61 73 74 2d 65 63 20 64 65 66 61 75 (last-ec defau
7ac0: 6c 74 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e lt (nested q1 ..
7ad0: 2e 20 71 29 20 65 74 63 31 20 65 74 63 20 2e 2e . q) etc1 etc ..
7ae0: 2e 29 20 29 0a 20 20 20 20 28 28 6c 61 73 74 2d .) ). ((last-
7af0: 65 63 20 64 65 66 61 75 6c 74 20 71 31 20 71 32 ec default q1 q2
7b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 74 63 etc
7b10: 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 1 etc ...).
7b20: 28 6c 61 73 74 2d 65 63 20 64 65 66 61 75 6c 74 (last-ec default
7b30: 20 28 6e 65 73 74 65 64 20 71 31 20 71 32 29 20 (nested q1 q2)
7b40: 20 20 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 etc1 etc ...)
7b50: 20 29 0a 20 20 20 20 28 28 6c 61 73 74 2d 65 63 ). ((last-ec
7b60: 20 64 65 66 61 75 6c 74 20 65 78 70 72 65 73 73 default express
7b70: 69 6f 6e 29 0a 20 20 20 20 20 28 6c 61 73 74 2d ion). (last-
7b80: 65 63 20 64 65 66 61 75 6c 74 20 28 6e 65 73 74 ec default (nest
7b90: 65 64 29 20 65 78 70 72 65 73 73 69 6f 6e 29 20 ed) expression)
7ba0: 29 0a 0a 20 20 20 20 28 28 6c 61 73 74 2d 65 63 ).. ((last-ec
7bb0: 20 64 65 66 61 75 6c 74 20 71 75 61 6c 69 66 69 default qualifi
7bc0: 65 72 20 65 78 70 72 65 73 73 69 6f 6e 29 0a 20 er expression).
7bd0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 75 6c (let ((resul
7be0: 74 20 64 65 66 61 75 6c 74 29 29 0a 20 20 20 20 t default)).
7bf0: 20 20 20 28 64 6f 2d 65 63 20 71 75 61 6c 69 66 (do-ec qualif
7c00: 69 65 72 20 28 73 65 74 21 20 72 65 73 75 6c 74 ier (set! result
7c10: 20 65 78 70 72 65 73 73 69 6f 6e 29 29 0a 20 20 expression)).
7c20: 20 20 20 20 20 72 65 73 75 6c 74 20 29 29 29 29 result ))))
7c30: 0a 0a 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ...; ===========
7c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7c80: 3b 20 54 68 65 20 66 75 6e 64 61 6d 65 6e 74 61 ; The fundamenta
7c90: 6c 20 65 61 72 6c 79 2d 73 74 6f 70 70 69 6e 67 l early-stopping
7ca0: 20 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 20 66 comprehension f
7cb0: 69 72 73 74 2d 65 63 0a 3b 20 3d 3d 3d 3d 3d 3d irst-ec.; ======
7cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d00: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d 73 79 ====..(define-sy
7d10: 6e 74 61 78 20 66 69 72 73 74 2d 65 63 0a 20 20 ntax first-ec.
7d20: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 6e (syntax-rules (n
7d30: 65 73 74 65 64 29 0a 20 20 20 20 28 28 66 69 72 ested). ((fir
7d40: 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 28 6e st-ec default (n
7d50: 65 73 74 65 64 20 71 31 20 2e 2e 2e 29 20 71 20 ested q1 ...) q
7d60: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 etc1 etc ...).
7d70: 20 20 20 28 66 69 72 73 74 2d 65 63 20 64 65 66 (first-ec def
7d80: 61 75 6c 74 20 28 6e 65 73 74 65 64 20 71 31 20 ault (nested q1
7d90: 2e 2e 2e 20 71 29 20 65 74 63 31 20 65 74 63 20 ... q) etc1 etc
7da0: 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 66 69 72 ...) ). ((fir
7db0: 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 71 31 st-ec default q1
7dc0: 20 71 32 20 20 20 20 20 20 20 20 20 20 20 20 20 q2
7dd0: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 etc1 etc ...).
7de0: 20 20 20 28 66 69 72 73 74 2d 65 63 20 64 65 66 (first-ec def
7df0: 61 75 6c 74 20 28 6e 65 73 74 65 64 20 71 31 20 ault (nested q1
7e00: 71 32 29 20 20 20 20 65 74 63 31 20 65 74 63 20 q2) etc1 etc
7e10: 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 66 69 72 ...) ). ((fir
7e20: 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 65 78 st-ec default ex
7e30: 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 pression). (
7e40: 66 69 72 73 74 2d 65 63 20 64 65 66 61 75 6c 74 first-ec default
7e50: 20 28 6e 65 73 74 65 64 29 20 65 78 70 72 65 73 (nested) expres
7e60: 73 69 6f 6e 29 20 29 0a 0a 20 20 20 20 28 28 66 sion) ).. ((f
7e70: 69 72 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 irst-ec default
7e80: 71 75 61 6c 69 66 69 65 72 20 65 78 70 72 65 73 qualifier expres
7e90: 73 69 6f 6e 29 0a 20 20 20 20 20 28 6c 65 74 20 sion). (let
7ea0: 28 28 72 65 73 75 6c 74 20 64 65 66 61 75 6c 74 ((result default
7eb0: 29 20 28 73 74 6f 70 20 23 66 29 29 0a 20 20 20 ) (stop #f)).
7ec0: 20 20 20 20 28 65 63 2d 67 75 61 72 64 65 64 2d (ec-guarded-
7ed0: 64 6f 2d 65 63 20 0a 20 20 20 20 20 20 20 20 20 do-ec .
7ee0: 73 74 6f 70 20 0a 20 20 20 20 20 20 20 20 20 28 stop . (
7ef0: 6e 65 73 74 65 64 20 71 75 61 6c 69 66 69 65 72 nested qualifier
7f00: 29 0a 20 20 20 20 20 20 20 20 20 28 62 65 67 69 ). (begi
7f10: 6e 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 65 n (set! result e
7f20: 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 xpression).
7f30: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
7f40: 20 73 74 6f 70 20 23 74 29 20 29 29 0a 20 20 20 stop #t) )).
7f50: 20 20 20 20 72 65 73 75 6c 74 20 29 29 29 29 0a result )))).
7f60: 0a 3b 20 28 65 63 2d 67 75 61 72 64 65 64 2d 64 .; (ec-guarded-d
7f70: 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 o-ec stop (neste
7f80: 64 20 71 20 2e 2e 2e 29 20 63 6d 64 29 0a 3b 20 d q ...) cmd).;
7f90: 20 20 63 6f 6e 73 74 72 75 63 74 73 20 28 64 6f constructs (do
7fa0: 2d 65 63 20 71 20 2e 2e 2e 20 63 6d 64 29 20 77 -ec q ... cmd) w
7fb0: 68 65 72 65 20 74 68 65 20 67 65 6e 65 72 61 74 here the generat
7fc0: 6f 72 73 20 67 65 6e 20 69 6e 20 71 20 2e 2e 2e ors gen in q ...
7fd0: 20 61 72 65 0a 3b 20 20 20 72 65 70 6c 61 63 65 are.; replace
7fe0: 64 20 62 79 20 28 3a 75 6e 74 69 6c 20 67 65 6e d by (:until gen
7ff0: 20 73 74 6f 70 29 2e 0a 0a 28 64 65 66 69 6e 65 stop)...(define
8000: 2d 73 79 6e 74 61 78 20 65 63 2d 67 75 61 72 64 -syntax ec-guard
8010: 65 64 2d 64 6f 2d 65 63 0a 20 20 28 73 79 6e 74 ed-do-ec. (synt
8020: 61 78 2d 72 75 6c 65 73 20 28 6e 65 73 74 65 64 ax-rules (nested
8030: 20 69 66 20 6e 6f 74 20 61 6e 64 20 6f 72 20 62 if not and or b
8040: 65 67 69 6e 29 0a 0a 20 20 20 20 28 28 65 63 2d egin).. ((ec-
8050: 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 guarded-do-ec st
8060: 6f 70 20 28 6e 65 73 74 65 64 20 28 6e 65 73 74 op (nested (nest
8070: 65 64 20 71 31 20 2e 2e 2e 29 20 71 32 20 2e 2e ed q1 ...) q2 ..
8080: 2e 29 20 63 6d 64 29 0a 20 20 20 20 20 28 65 63 .) cmd). (ec
8090: 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 -guarded-do-ec s
80a0: 74 6f 70 20 28 6e 65 73 74 65 64 20 71 31 20 2e top (nested q1 .
80b0: 2e 2e 20 71 32 20 2e 2e 2e 29 20 63 6d 64 29 20 .. q2 ...) cmd)
80c0: 29 0a 0a 20 20 20 20 28 28 65 63 2d 67 75 61 72 ).. ((ec-guar
80d0: 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 28 ded-do-ec stop (
80e0: 6e 65 73 74 65 64 20 28 69 66 20 74 65 73 74 29 nested (if test)
80f0: 20 71 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 20 q ...) cmd).
8100: 20 20 28 69 66 20 74 65 73 74 20 28 65 63 2d 67 (if test (ec-g
8110: 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f uarded-do-ec sto
8120: 70 20 28 6e 65 73 74 65 64 20 71 20 2e 2e 2e 29 p (nested q ...)
8130: 20 63 6d 64 29 29 20 29 0a 20 20 20 20 28 28 65 cmd)) ). ((e
8140: 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 c-guarded-do-ec
8150: 73 74 6f 70 20 28 6e 65 73 74 65 64 20 28 6e 6f stop (nested (no
8160: 74 20 74 65 73 74 29 20 71 20 2e 2e 2e 29 20 63 t test) q ...) c
8170: 6d 64 29 0a 20 20 20 20 20 28 69 66 20 28 6e 6f md). (if (no
8180: 74 20 74 65 73 74 29 20 28 65 63 2d 67 75 61 72 t test) (ec-guar
8190: 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 28 ded-do-ec stop (
81a0: 6e 65 73 74 65 64 20 71 20 2e 2e 2e 29 20 63 6d nested q ...) cm
81b0: 64 29 29 20 29 0a 20 20 20 20 28 28 65 63 2d 67 d)) ). ((ec-g
81c0: 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f uarded-do-ec sto
81d0: 70 20 28 6e 65 73 74 65 64 20 28 61 6e 64 20 74 p (nested (and t
81e0: 65 73 74 20 2e 2e 2e 29 20 71 20 2e 2e 2e 29 20 est ...) q ...)
81f0: 63 6d 64 29 0a 20 20 20 20 20 28 69 66 20 28 61 cmd). (if (a
8200: 6e 64 20 74 65 73 74 20 2e 2e 2e 29 20 28 65 63 nd test ...) (ec
8210: 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 -guarded-do-ec s
8220: 74 6f 70 20 28 6e 65 73 74 65 64 20 71 20 2e 2e top (nested q ..
8230: 2e 29 20 63 6d 64 29 29 20 29 0a 20 20 20 20 28 .) cmd)) ). (
8240: 28 65 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 (ec-guarded-do-e
8250: 63 20 73 74 6f 70 20 28 6e 65 73 74 65 64 20 28 c stop (nested (
8260: 6f 72 20 74 65 73 74 20 2e 2e 2e 29 20 71 20 2e or test ...) q .
8270: 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 20 28 69 ..) cmd). (i
8280: 66 20 28 6f 72 20 74 65 73 74 20 2e 2e 2e 29 20 f (or test ...)
8290: 28 65 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 (ec-guarded-do-e
82a0: 63 20 73 74 6f 70 20 28 6e 65 73 74 65 64 20 71 c stop (nested q
82b0: 20 2e 2e 2e 29 20 63 6d 64 29 29 20 29 0a 0a 20 ...) cmd)) )..
82c0: 20 20 20 28 28 65 63 2d 67 75 61 72 64 65 64 2d ((ec-guarded-
82d0: 64 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 do-ec stop (nest
82e0: 65 64 20 28 62 65 67 69 6e 20 65 74 63 20 2e 2e ed (begin etc ..
82f0: 2e 29 20 71 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 .) q ...) cmd).
8300: 20 20 20 20 28 62 65 67 69 6e 20 65 74 63 20 2e (begin etc .
8310: 2e 2e 20 28 65 63 2d 67 75 61 72 64 65 64 2d 64 .. (ec-guarded-d
8320: 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 o-ec stop (neste
8330: 64 20 71 20 2e 2e 2e 29 20 63 6d 64 29 29 20 29 d q ...) cmd)) )
8340: 0a 0a 20 20 20 20 28 28 65 63 2d 67 75 61 72 64 .. ((ec-guard
8350: 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 28 6e ed-do-ec stop (n
8360: 65 73 74 65 64 20 67 65 6e 20 71 20 2e 2e 2e 29 ested gen q ...)
8370: 20 63 6d 64 29 0a 20 20 20 20 20 28 64 6f 2d 65 cmd). (do-e
8380: 63 20 0a 20 20 20 20 20 20 20 28 3a 75 6e 74 69 c . (:unti
8390: 6c 20 67 65 6e 20 73 74 6f 70 29 20 0a 20 20 20 l gen stop) .
83a0: 20 20 20 20 28 65 63 2d 67 75 61 72 64 65 64 2d (ec-guarded-
83b0: 64 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 do-ec stop (nest
83c0: 65 64 20 71 20 2e 2e 2e 29 20 63 6d 64 29 20 29 ed q ...) cmd) )
83d0: 29 0a 0a 20 20 20 20 28 28 65 63 2d 67 75 61 72 ).. ((ec-guar
83e0: 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 28 ded-do-ec stop (
83f0: 6e 65 73 74 65 64 29 20 63 6d 64 29 0a 20 20 20 nested) cmd).
8400: 20 20 28 64 6f 2d 65 63 20 63 6d 64 29 20 29 29 (do-ec cmd) ))
8410: 29 0a 0a 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 )..; Alternative
8420: 3a 20 49 6e 73 74 65 61 64 20 6f 66 20 6d 6f 64 : Instead of mod
8430: 69 66 79 69 6e 67 20 74 68 65 20 67 65 6e 65 72 ifying the gener
8440: 61 74 6f 72 20 77 69 74 68 20 3a 75 6e 74 69 6c ator with :until
8450: 2c 20 69 74 20 69 73 0a 3b 20 20 20 70 6f 73 73 , it is.; poss
8460: 69 62 6c 65 20 74 6f 20 75 73 65 20 63 61 6c 6c ible to use call
8470: 2d 77 69 74 68 2d 63 75 72 72 65 6e 74 2d 63 6f -with-current-co
8480: 6e 74 69 6e 75 61 74 69 6f 6e 3a 0a 3b 0a 3b 20 ntinuation:.;.;
8490: 20 20 28 64 65 66 69 6e 65 2d 73 79 6e 61 74 78 (define-synatx
84a0: 20 66 69 72 73 74 2d 65 63 20 0a 3b 20 20 20 20 first-ec .;
84b0: 20 2e 2e 2e 73 61 6d 65 20 61 73 20 61 62 6f 76 ...same as abov
84c0: 65 2e 2e 2e 0a 3b 20 20 20 20 20 28 28 66 69 72 e....; ((fir
84d0: 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 71 75 st-ec default qu
84e0: 61 6c 69 66 69 65 72 20 65 78 70 72 65 73 73 69 alifier expressi
84f0: 6f 6e 29 0a 3b 20 20 20 20 20 20 28 63 61 6c 6c on).; (call
8500: 2d 77 69 74 68 2d 63 75 72 72 65 6e 74 2d 63 6f -with-current-co
8510: 6e 74 69 6e 75 61 74 69 6f 6e 20 0a 3b 20 20 20 ntinuation .;
8520: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 63 63 29 (lambda (cc)
8530: 0a 3b 20 20 20 20 20 20 20 20 28 64 6f 2d 65 63 .; (do-ec
8540: 20 71 75 61 6c 69 66 69 65 72 20 28 63 63 20 65 qualifier (cc e
8550: 78 70 72 65 73 73 69 6f 6e 29 29 0a 3b 20 20 20 xpression)).;
8560: 20 20 20 20 20 64 65 66 61 75 6c 74 20 29 29 29 default )))
8570: 20 29 29 0a 3b 0a 3b 20 20 20 54 68 69 73 20 69 )).;.; This i
8580: 73 20 6d 75 63 68 20 73 69 6d 70 6c 65 72 20 62 s much simpler b
8590: 75 74 20 6e 6f 74 20 6e 65 63 65 73 73 61 72 69 ut not necessari
85a0: 6c 79 20 61 73 20 65 66 66 69 63 69 65 6e 74 2e ly as efficient.
85b0: 0a 0a 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ...; ===========
85c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
85f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8600: 3b 20 54 68 65 20 65 61 72 6c 79 2d 73 74 6f 70 ; The early-stop
8610: 70 69 6e 67 20 63 6f 6d 70 72 65 68 65 6e 73 69 ping comprehensi
8620: 6f 6e 73 20 61 6e 79 3f 2d 65 63 20 65 76 65 72 ons any?-ec ever
8630: 79 3f 2d 65 63 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d y?-ec.; ========
8640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8680: 3d 3d 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ==..(define-synt
8690: 61 78 20 61 6e 79 3f 2d 65 63 0a 20 20 28 73 79 ax any?-ec. (sy
86a0: 6e 74 61 78 2d 72 75 6c 65 73 20 28 6e 65 73 74 ntax-rules (nest
86b0: 65 64 29 0a 20 20 20 20 28 28 61 6e 79 3f 2d 65 ed). ((any?-e
86c0: 63 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e c (nested q1 ...
86d0: 29 20 71 20 65 74 63 31 20 65 74 63 20 2e 2e 2e ) q etc1 etc ...
86e0: 29 0a 20 20 20 20 20 28 61 6e 79 3f 2d 65 63 20 ). (any?-ec
86f0: 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 20 71 (nested q1 ... q
8700: 29 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 20 ) etc1 etc ...)
8710: 29 0a 20 20 20 20 28 28 61 6e 79 3f 2d 65 63 20 ). ((any?-ec
8720: 71 31 20 71 32 20 20 20 20 20 20 20 20 20 20 20 q1 q2
8730: 20 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a etc1 etc ...).
8740: 20 20 20 20 20 28 61 6e 79 3f 2d 65 63 20 28 6e (any?-ec (n
8750: 65 73 74 65 64 20 71 31 20 71 32 29 20 20 20 20 ested q1 q2)
8760: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a etc1 etc ...) ).
8770: 20 20 20 20 28 28 61 6e 79 3f 2d 65 63 20 65 78 ((any?-ec ex
8780: 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 pression). (
8790: 61 6e 79 3f 2d 65 63 20 28 6e 65 73 74 65 64 29 any?-ec (nested)
87a0: 20 65 78 70 72 65 73 73 69 6f 6e 29 20 29 0a 0a expression) )..
87b0: 20 20 20 20 28 28 61 6e 79 3f 2d 65 63 20 71 75 ((any?-ec qu
87c0: 61 6c 69 66 69 65 72 20 65 78 70 72 65 73 73 69 alifier expressi
87d0: 6f 6e 29 0a 20 20 20 20 20 28 66 69 72 73 74 2d on). (first-
87e0: 65 63 20 23 66 20 71 75 61 6c 69 66 69 65 72 20 ec #f qualifier
87f0: 28 69 66 20 65 78 70 72 65 73 73 69 6f 6e 29 20 (if expression)
8800: 23 74 29 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 #t) )))..(define
8810: 2d 73 79 6e 74 61 78 20 65 76 65 72 79 3f 2d 65 -syntax every?-e
8820: 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 c. (syntax-rule
8830: 73 20 28 6e 65 73 74 65 64 29 0a 20 20 20 20 28 s (nested). (
8840: 28 65 76 65 72 79 3f 2d 65 63 20 28 6e 65 73 74 (every?-ec (nest
8850: 65 64 20 71 31 20 2e 2e 2e 29 20 71 20 65 74 63 ed q1 ...) q etc
8860: 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 1 etc ...).
8870: 28 65 76 65 72 79 3f 2d 65 63 20 28 6e 65 73 74 (every?-ec (nest
8880: 65 64 20 71 31 20 2e 2e 2e 20 71 29 20 65 74 63 ed q1 ... q) etc
8890: 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 20 1 etc ...) ).
88a0: 20 28 28 65 76 65 72 79 3f 2d 65 63 20 71 31 20 ((every?-ec q1
88b0: 71 32 20 20 20 20 20 20 20 20 20 20 20 20 20 65 q2 e
88c0: 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 tc1 etc ...).
88d0: 20 20 28 65 76 65 72 79 3f 2d 65 63 20 28 6e 65 (every?-ec (ne
88e0: 73 74 65 64 20 71 31 20 71 32 29 20 20 20 20 65 sted q1 q2) e
88f0: 74 63 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 tc1 etc ...) ).
8900: 20 20 20 28 28 65 76 65 72 79 3f 2d 65 63 20 65 ((every?-ec e
8910: 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 xpression).
8920: 28 65 76 65 72 79 3f 2d 65 63 20 28 6e 65 73 74 (every?-ec (nest
8930: 65 64 29 20 65 78 70 72 65 73 73 69 6f 6e 29 20 ed) expression)
8940: 29 0a 0a 20 20 20 20 28 28 65 76 65 72 79 3f 2d ).. ((every?-
8950: 65 63 20 71 75 61 6c 69 66 69 65 72 20 65 78 70 ec qualifier exp
8960: 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 66 ression). (f
8970: 69 72 73 74 2d 65 63 20 23 74 20 71 75 61 6c 69 irst-ec #t quali
8980: 66 69 65 72 20 28 69 66 20 28 6e 6f 74 20 65 78 fier (if (not ex
8990: 70 72 65 73 73 69 6f 6e 29 29 20 23 66 29 20 29 pression)) #f) )
89a0: 29 29 0a 0a 20 20 0a 0a 20 20 0a 29 0a )).. .. .).