Artifact
04a5869671db6d7b8f920fbe015cb1c01f11b6df:
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 65 78 63 65 import. (exce
0310: 70 74 20 28 72 6e 72 73 29 20 65 72 72 6f 72 29 pt (rnrs) error)
0320: 0a 20 20 20 20 28 72 6e 72 73 20 72 35 72 73 29 . (rnrs r5rs)
0330: 0a 20 20 20 20 28 73 72 66 69 20 73 33 39 20 70 . (srfi s39 p
0340: 61 72 61 6d 65 74 65 72 73 29 0a 20 20 20 20 3b arameters). ;
0350: 3b 20 28 73 72 66 69 20 73 32 33 20 65 72 72 6f ; (srfi s23 erro
0360: 72 20 74 72 69 63 6b 73 29 0a 20 20 20 20 28 73 r tricks). (s
0370: 72 66 69 20 73 32 33 20 65 72 72 6f 72 29 0a 20 rfi s23 error).
0380: 20 20 20 28 73 72 66 69 20 70 72 69 76 61 74 65 (srfi private
0390: 20 69 6e 63 6c 75 64 65 29 29 0a 20 20 0a 20 20 include)). .
03a0: 3b 3b 20 28 53 52 46 49 2d 32 33 2d 65 72 72 6f ;; (SRFI-23-erro
03b0: 72 2d 3e 52 36 52 53 20 22 28 6c 69 62 72 61 72 r->R6RS "(librar
03c0: 79 20 28 73 72 66 69 20 73 34 32 20 65 61 67 65 y (srfi s42 eage
03d0: 72 2d 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 73 r-comprehensions
03e0: 29 29 22 0a 20 20 3b 3b 20 20 20 28 69 6e 63 6c ))". ;; (incl
03f0: 75 64 65 2f 72 65 73 6f 6c 76 65 20 28 22 73 72 ude/resolve ("sr
0400: 66 69 22 20 22 73 34 32 22 29 20 22 65 63 2e 73 fi" "s42") "ec.s
0410: 63 6d 22 29 29 0a 0a 3b 20 3c 50 4c 41 49 4e 54 cm"))..; <PLAINT
0420: 45 58 54 3e 0a 3b 20 45 61 67 65 72 20 43 6f 6d EXT>.; Eager Com
0430: 70 72 65 68 65 6e 73 69 6f 6e 73 20 69 6e 20 5b prehensions in [
0440: 6f 75 74 65 72 2e 2e 69 6e 6e 65 72 7c 65 78 70 outer..inner|exp
0450: 72 5d 2d 43 6f 6e 76 65 6e 74 69 6f 6e 0a 3b 20 r]-Convention.;
0460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 0a 3b 0a 3b 20 73 65 62 61 73 ======.;.; sebas
04a0: 74 69 61 6e 2e 65 67 6e 65 72 40 70 68 69 6c 69 tian.egner@phili
04b0: 70 73 2e 63 6f 6d 2c 20 45 69 6e 64 68 6f 76 65 ps.com, Eindhove
04c0: 6e 2c 20 54 68 65 20 4e 65 74 68 65 72 6c 61 6e n, The Netherlan
04d0: 64 73 2c 20 32 35 2d 41 70 72 2d 32 30 30 35 0a ds, 25-Apr-2005.
04e0: 3b 20 53 63 68 65 6d 65 20 52 35 52 53 20 28 69 ; Scheme R5RS (i
04f0: 6e 63 6c 2e 20 6d 61 63 72 6f 73 29 2c 20 53 52 ncl. macros), SR
0500: 46 49 2d 32 33 20 28 65 72 72 6f 72 29 2e 0a 3b FI-23 (error)..;
0510: 0a 3b 20 4d 6f 64 69 66 69 65 64 20 62 79 20 44 .; Modified by D
0520: 65 72 69 63 6b 20 45 64 64 69 6e 67 74 6f 6e 20 erick Eddington
0530: 74 6f 20 62 65 20 61 62 6c 65 20 74 6f 20 62 65 to be able to be
0540: 20 69 6e 63 6c 75 64 65 64 20 69 6e 74 6f 20 61 included into a
0550: 6e 20 52 36 52 53 20 6c 69 62 72 61 72 79 2e 0a n R6RS library..
0560: 3b 20 0a 3b 20 4c 6f 61 64 69 6e 67 20 74 68 65 ; .; Loading the
0570: 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 implementation
0580: 69 6e 74 6f 20 53 63 68 65 6d 65 34 38 20 30 2e into Scheme48 0.
0590: 35 37 3a 0a 3b 20 20 20 2c 6f 70 65 6e 20 73 72 57:.; ,open sr
05a0: 66 69 2d 32 33 0a 3b 20 20 20 2c 6c 6f 61 64 20 fi-23.; ,load
05b0: 65 63 2e 73 63 6d 0a 3b 0a 3b 20 4c 6f 61 64 69 ec.scm.;.; Loadi
05c0: 6e 67 20 74 68 65 20 69 6d 70 6c 65 6d 65 6e 74 ng the implement
05d0: 61 74 69 6f 6e 20 69 6e 74 6f 20 50 4c 54 2f 44 ation into PLT/D
05e0: 72 53 63 68 65 6d 65 20 32 30 32 3a 0a 3b 20 20 rScheme 202:.;
05f0: 20 3b 20 46 69 6c 65 20 3e 20 4f 70 65 6e 20 2e ; File > Open .
0600: 2e 2e 20 22 65 63 2e 73 63 6d 22 2c 20 63 6c 69 .. "ec.scm", cli
0610: 63 6b 20 45 78 65 63 75 74 65 0a 3b 0a 3b 20 4c ck Execute.;.; L
0620: 6f 61 64 69 6e 67 20 74 68 65 20 69 6d 70 6c 65 oading the imple
0630: 6d 65 6e 74 61 74 69 6f 6e 20 69 6e 74 6f 20 53 mentation into S
0640: 43 4d 20 35 64 37 3a 0a 3b 20 20 20 28 72 65 71 CM 5d7:.; (req
0650: 75 69 72 65 20 27 6d 61 63 72 6f 29 20 28 72 65 uire 'macro) (re
0660: 71 75 69 72 65 20 27 72 65 63 6f 72 64 29 20 0a quire 'record) .
0670: 3b 20 20 20 28 6c 6f 61 64 20 22 65 63 2e 73 63 ; (load "ec.sc
0680: 6d 22 29 0a 3b 0a 3b 20 49 6d 70 6c 65 6d 65 6e m").;.; Implemen
0690: 74 61 74 69 6f 6e 20 63 6f 6d 6d 65 6e 74 73 3a tation comments:
06a0: 0a 3b 20 20 20 2a 20 41 6c 6c 20 6c 6f 63 61 6c .; * All local
06b0: 20 28 6e 6f 74 20 65 78 70 6f 72 74 65 64 29 20 (not exported)
06c0: 69 64 65 6e 74 69 66 69 65 72 73 20 61 72 65 20 identifiers are
06d0: 6e 61 6d 65 64 20 65 63 2d 3c 73 6f 6d 65 74 68 named ec-<someth
06e0: 69 6e 67 3e 2e 0a 3b 20 20 20 2a 20 54 68 69 73 ing>..; * This
06f0: 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 implementation
0700: 66 6f 63 75 73 65 73 20 6f 6e 20 70 6f 72 74 61 focuses on porta
0710: 62 69 6c 69 74 79 2c 20 70 65 72 66 6f 72 6d 61 bility, performa
0720: 6e 63 65 2c 20 0a 3b 20 20 20 20 20 72 65 61 64 nce, .; read
0730: 61 62 69 6c 69 74 79 2c 20 61 6e 64 20 73 69 6d ability, and sim
0740: 70 6c 69 63 69 74 79 20 72 6f 75 67 68 6c 79 20 plicity roughly
0750: 69 6e 20 74 68 69 73 20 6f 72 64 65 72 2e 20 44 in this order. D
0760: 65 73 69 67 6e 0a 3b 20 20 20 20 20 64 65 63 69 esign.; deci
0770: 73 69 6f 6e 73 20 72 65 6c 61 74 65 64 20 74 6f sions related to
0780: 20 70 65 72 66 6f 72 6d 61 6e 63 65 20 61 72 65 performance are
0790: 20 74 61 6b 65 6e 20 66 6f 72 20 53 63 68 65 6d taken for Schem
07a0: 65 34 38 2e 0a 3b 20 20 20 2a 20 41 6c 74 65 72 e48..; * Alter
07b0: 6e 61 74 69 76 65 20 69 6d 70 6c 65 6d 65 6e 74 native implement
07c0: 61 74 69 6f 6e 73 2c 20 43 6f 6d 6d 65 6e 74 73 ations, Comments
07d0: 20 61 6e 64 20 57 61 72 6e 69 6e 67 73 20 61 72 and Warnings ar
07e0: 65 20 0a 3b 20 20 20 20 20 6d 65 6e 74 69 6f 6e e .; mention
07f0: 65 64 20 61 66 74 65 72 20 74 68 65 20 64 65 66 ed after the def
0800: 69 6e 69 74 69 6f 6e 20 77 69 74 68 20 61 20 68 inition with a h
0810: 65 61 64 69 6e 67 2e 0a 0a 0a 3b 20 3d 3d 3d 3d eading....; ====
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: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0860: 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 66 75 6e ======.; The fun
0870: 64 61 6d 65 6e 74 61 6c 20 63 6f 6d 70 72 65 68 damental compreh
0880: 65 6e 73 69 6f 6e 20 64 6f 2d 65 63 0a 3b 20 3d ension do-ec.; =
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 0a 3b 20 41 6c =========.;.; Al
08e0: 6c 20 65 61 67 65 72 20 63 6f 6d 70 72 65 68 65 l eager comprehe
08f0: 6e 73 69 6f 6e 73 20 61 72 65 20 72 65 64 75 63 nsions are reduc
0900: 65 64 20 69 6e 74 6f 20 64 6f 2d 65 63 20 61 6e ed into do-ec an
0910: 64 0a 3b 20 61 6c 6c 20 67 65 6e 65 72 61 74 6f d.; all generato
0920: 72 73 20 61 72 65 20 72 65 64 75 63 65 64 20 74 rs are reduced t
0930: 6f 20 3a 64 6f 2e 20 0a 3b 0a 3b 20 57 65 20 75 o :do. .;.; We u
0940: 73 65 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 se the following
0950: 20 73 68 6f 72 74 20 6e 61 6d 65 73 20 66 6f 72 short names for
0960: 20 73 79 6e 74 61 63 74 69 63 20 76 61 72 69 61 syntactic varia
0970: 62 6c 65 73 0a 3b 20 20 20 71 20 20 20 20 2d 20 bles.; q -
0980: 71 75 61 6c 69 66 69 65 72 0a 3b 20 20 20 63 63 qualifier.; cc
0990: 20 20 20 2d 20 63 75 72 72 65 6e 74 20 63 6f 6e - current con
09a0: 74 69 6e 75 61 74 69 6f 6e 2c 20 74 68 69 6e 67 tinuation, thing
09b0: 20 74 6f 20 63 61 6c 6c 20 61 74 20 74 68 65 20 to call at the
09c0: 65 6e 64 3b 0a 3b 20 20 20 20 20 20 20 20 20 20 end;.;
09d0: 74 68 65 20 43 50 53 20 69 73 20 28 6d 20 28 63 the CPS is (m (c
09e0: 63 20 2e 2e 2e 29 20 61 72 67 20 2e 2e 2e 29 20 c ...) arg ...)
09f0: 2d 3e 20 28 63 63 20 2e 2e 2e 20 65 78 70 72 20 -> (cc ... expr
0a00: 2e 2e 2e 29 0a 3b 20 20 20 63 6d 64 20 20 2d 20 ...).; cmd -
0a10: 61 6e 20 65 78 70 72 65 73 73 69 6f 6e 20 62 65 an expression be
0a20: 69 6e 67 20 65 76 61 6c 75 61 74 65 64 20 66 6f ing evaluated fo
0a30: 72 20 69 74 73 20 73 69 64 65 2d 65 66 66 65 63 r its side-effec
0a40: 74 73 0a 3b 20 20 20 65 78 70 72 20 2d 20 61 6e ts.; expr - an
0a50: 20 65 78 70 72 65 73 73 69 6f 6e 0a 3b 20 20 20 expression.;
0a60: 67 65 6e 20 20 2d 20 61 20 67 65 6e 65 72 61 74 gen - a generat
0a70: 6f 72 20 6f 66 20 61 6e 20 65 61 67 65 72 20 63 or of an eager c
0a80: 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 0a 3b 20 20 omprehension.;
0a90: 20 6f 62 20 20 20 2d 20 6f 75 74 65 72 20 62 69 ob - outer bi
0aa0: 6e 64 69 6e 67 0a 3b 20 20 20 6f 63 20 20 20 2d nding.; oc -
0ab0: 20 6f 75 74 65 72 20 63 6f 6d 6d 61 6e 64 0a 3b outer command.;
0ac0: 20 20 20 6c 62 20 20 20 2d 20 6c 6f 6f 70 20 62 lb - loop b
0ad0: 69 6e 64 69 6e 67 0a 3b 20 20 20 6e 65 31 3f 20 inding.; ne1?
0ae0: 2d 20 6e 6f 74 2d 65 6e 64 31 3f 20 28 62 65 66 - not-end1? (bef
0af0: 6f 72 65 20 74 68 65 20 70 61 79 6c 6f 61 64 29 ore the payload)
0b00: 0a 3b 20 20 20 69 62 20 20 20 2d 20 69 6e 6e 65 .; ib - inne
0b10: 72 20 62 69 6e 64 69 6e 67 0a 3b 20 20 20 69 63 r binding.; ic
0b20: 20 20 20 2d 20 69 6e 6e 65 72 20 63 6f 6d 6d 61 - inner comma
0b30: 6e 64 0a 3b 20 20 20 6e 65 32 3f 20 2d 20 6e 6f nd.; ne2? - no
0b40: 74 2d 65 6e 64 32 3f 20 28 61 66 74 65 72 20 74 t-end2? (after t
0b50: 68 65 20 70 61 79 6c 6f 61 64 29 0a 3b 20 20 20 he payload).;
0b60: 6c 73 20 20 20 2d 20 6c 6f 6f 70 20 73 74 65 70 ls - loop step
0b70: 0a 3b 20 20 20 65 74 63 20 20 2d 20 6d 6f 72 65 .; etc - more
0b80: 20 61 72 67 75 6d 65 6e 74 73 20 6f 66 20 6d 69 arguments of mi
0b90: 78 65 64 20 74 79 70 65 0a 0a 0a 3b 20 28 64 6f xed type...; (do
0ba0: 2d 65 63 20 71 20 2e 2e 2e 20 63 6d 64 29 0a 3b -ec q ... cmd).;
0bb0: 20 20 20 68 61 6e 64 6c 65 73 20 6e 65 73 74 65 handles neste
0bc0: 64 2c 20 69 66 2f 6e 6f 74 2f 61 6e 64 2f 6f 72 d, if/not/and/or
0bd0: 2c 20 62 65 67 69 6e 2c 20 3a 6c 65 74 2c 20 61 , begin, :let, a
0be0: 6e 64 20 63 61 6c 6c 73 20 67 65 6e 65 72 61 74 nd calls generat
0bf0: 6f 72 20 0a 3b 20 20 20 6d 61 63 72 6f 73 20 69 or .; macros i
0c00: 6e 20 43 50 53 20 74 6f 20 74 72 61 6e 73 66 6f n CPS to transfo
0c10: 72 6d 20 74 68 65 6d 20 69 6e 74 6f 20 66 75 6c rm them into ful
0c20: 6c 79 20 64 65 63 6f 72 61 74 65 64 20 3a 64 6f ly decorated :do
0c30: 2e 0a 3b 20 20 20 54 68 65 20 63 6f 64 65 20 67 ..; The code g
0c40: 65 6e 65 72 61 74 69 6f 6e 20 66 6f 72 20 61 20 eneration for a
0c50: 3a 64 6f 20 69 73 20 64 65 6c 65 67 61 74 65 64 :do is delegated
0c60: 20 74 6f 20 64 6f 2d 65 63 3a 64 6f 2e 0a 0a 28 to do-ec:do...(
0c70: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 64 6f define-syntax do
0c80: 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 -ec. (syntax-ru
0c90: 6c 65 73 20 28 6e 65 73 74 65 64 20 69 66 20 6e les (nested if n
0ca0: 6f 74 20 61 6e 64 20 6f 72 20 62 65 67 69 6e 20 ot and or begin
0cb0: 3a 64 6f 20 6c 65 74 29 0a 0a 20 20 20 20 3b 20 :do let).. ;
0cc0: 65 78 70 6c 69 63 69 74 20 6e 65 73 74 69 6e 67 explicit nesting
0cd0: 20 2d 3e 20 69 6d 70 6c 69 63 69 74 20 6e 65 73 -> implicit nes
0ce0: 74 69 6e 67 0a 20 20 20 20 28 28 64 6f 2d 65 63 ting. ((do-ec
0cf0: 20 28 6e 65 73 74 65 64 20 71 20 2e 2e 2e 29 20 (nested q ...)
0d00: 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 64 etc ...). (d
0d10: 6f 2d 65 63 20 71 20 2e 2e 2e 20 65 74 63 20 2e o-ec q ... etc .
0d20: 2e 2e 29 20 29 0a 0a 20 20 20 20 3b 20 69 6d 70 ..) ).. ; imp
0d30: 6c 69 63 69 74 20 6e 65 73 74 69 6e 67 20 2d 3e licit nesting ->
0d40: 20 66 6f 6c 64 20 64 6f 2d 65 63 0a 20 20 20 20 fold do-ec.
0d50: 28 28 64 6f 2d 65 63 20 71 31 20 71 32 20 65 74 ((do-ec q1 q2 et
0d60: 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 c1 etc ...).
0d70: 20 28 64 6f 2d 65 63 20 71 31 20 28 64 6f 2d 65 (do-ec q1 (do-e
0d80: 63 20 71 32 20 65 74 63 31 20 65 74 63 20 2e 2e c q2 etc1 etc ..
0d90: 2e 29 29 20 29 0a 0a 20 20 20 20 3b 20 6e 6f 20 .)) ).. ; no
0da0: 71 75 61 6c 69 66 69 65 72 73 20 61 74 20 61 6c qualifiers at al
0db0: 6c 20 2d 3e 20 65 76 61 6c 75 61 74 65 20 63 6d l -> evaluate cm
0dc0: 64 20 6f 6e 63 65 0a 20 20 20 20 28 28 64 6f 2d d once. ((do-
0dd0: 65 63 20 63 6d 64 29 0a 20 20 20 20 20 28 62 65 ec cmd). (be
0de0: 67 69 6e 20 63 6d 64 20 28 69 66 20 23 66 20 23 gin cmd (if #f #
0df0: 66 29 29 20 29 0a 0a 3b 20 6e 6f 77 20 28 64 6f f)) )..; now (do
0e00: 2d 65 63 20 71 20 63 6d 64 29 20 72 65 6d 61 69 -ec q cmd) remai
0e10: 6e 73 0a 0a 20 20 20 20 3b 20 66 69 6c 74 65 72 ns.. ; filter
0e20: 20 2d 3e 20 6d 61 6b 65 20 63 6f 6e 64 69 74 69 -> make conditi
0e30: 6f 6e 61 6c 0a 20 20 20 20 28 28 64 6f 2d 65 63 onal. ((do-ec
0e40: 20 28 69 66 20 74 65 73 74 29 20 63 6d 64 29 0a (if test) cmd).
0e50: 20 20 20 20 20 28 69 66 20 74 65 73 74 20 28 64 (if test (d
0e60: 6f 2d 65 63 20 63 6d 64 29 29 20 29 0a 20 20 20 o-ec cmd)) ).
0e70: 20 28 28 64 6f 2d 65 63 20 28 6e 6f 74 20 74 65 ((do-ec (not te
0e80: 73 74 29 20 63 6d 64 29 0a 20 20 20 20 20 28 69 st) cmd). (i
0e90: 66 20 28 6e 6f 74 20 74 65 73 74 29 20 28 64 6f f (not test) (do
0ea0: 2d 65 63 20 63 6d 64 29 29 20 29 0a 20 20 20 20 -ec cmd)) ).
0eb0: 28 28 64 6f 2d 65 63 20 28 61 6e 64 20 74 65 73 ((do-ec (and tes
0ec0: 74 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 t ...) cmd).
0ed0: 20 28 69 66 20 28 61 6e 64 20 74 65 73 74 20 2e (if (and test .
0ee0: 2e 2e 29 20 28 64 6f 2d 65 63 20 63 6d 64 29 29 ..) (do-ec cmd))
0ef0: 20 29 0a 20 20 20 20 28 28 64 6f 2d 65 63 20 28 ). ((do-ec (
0f00: 6f 72 20 74 65 73 74 20 2e 2e 2e 29 20 63 6d 64 or test ...) cmd
0f10: 29 0a 20 20 20 20 20 28 69 66 20 28 6f 72 20 74 ). (if (or t
0f20: 65 73 74 20 2e 2e 2e 29 20 28 64 6f 2d 65 63 20 est ...) (do-ec
0f30: 63 6d 64 29 29 20 29 0a 0a 20 20 20 20 3b 20 62 cmd)) ).. ; b
0f40: 65 67 69 6e 20 2d 3e 20 6d 61 6b 65 20 61 20 73 egin -> make a s
0f50: 65 71 75 65 6e 63 65 0a 20 20 20 20 28 28 64 6f equence. ((do
0f60: 2d 65 63 20 28 62 65 67 69 6e 20 65 74 63 20 2e -ec (begin etc .
0f70: 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 20 28 62 ..) cmd). (b
0f80: 65 67 69 6e 20 65 74 63 20 2e 2e 2e 20 28 64 6f egin etc ... (do
0f90: 2d 65 63 20 63 6d 64 29 29 20 29 0a 0a 20 20 20 -ec cmd)) )..
0fa0: 20 3b 20 66 75 6c 6c 79 20 64 65 63 6f 72 61 74 ; fully decorat
0fb0: 65 64 20 3a 64 6f 2d 67 65 6e 65 72 61 74 6f 72 ed :do-generator
0fc0: 20 2d 3e 20 64 65 6c 65 67 61 74 65 20 74 6f 20 -> delegate to
0fd0: 64 6f 2d 65 63 3a 64 6f 0a 20 20 20 20 28 28 64 do-ec:do. ((d
0fe0: 6f 2d 65 63 20 28 3a 64 6f 20 6f 6c 65 74 20 6c o-ec (:do olet l
0ff0: 62 73 20 6e 65 31 3f 20 69 6c 65 74 20 6e 65 32 bs ne1? ilet ne2
1000: 3f 20 6c 73 73 29 20 63 6d 64 29 0a 20 20 20 20 ? lss) cmd).
1010: 20 28 64 6f 2d 65 63 3a 64 6f 20 63 6d 64 20 28 (do-ec:do cmd (
1020: 3a 64 6f 20 6f 6c 65 74 20 6c 62 73 20 6e 65 31 :do olet lbs ne1
1030: 3f 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 73 29 ? ilet ne2? lss)
1040: 29 20 29 0a 0a 3b 20 61 6e 79 74 68 69 6e 67 20 ) )..; anything
1050: 65 6c 73 65 20 2d 3e 20 63 61 6c 6c 20 67 65 6e else -> call gen
1060: 65 72 61 74 6f 72 2d 6d 61 63 72 6f 20 69 6e 20 erator-macro in
1070: 43 50 53 3b 20 72 65 65 6e 74 72 79 20 61 74 20 CPS; reentry at
1080: 28 2a 29 0a 0a 20 20 20 20 28 28 64 6f 2d 65 63 (*).. ((do-ec
1090: 20 28 67 20 61 72 67 31 20 61 72 67 20 2e 2e 2e (g arg1 arg ...
10a0: 29 20 63 6d 64 29 0a 20 20 20 20 20 28 67 20 28 ) cmd). (g (
10b0: 64 6f 2d 65 63 3a 64 6f 20 63 6d 64 29 20 61 72 do-ec:do cmd) ar
10c0: 67 31 20 61 72 67 20 2e 2e 2e 29 20 29 29 29 0a g1 arg ...) ))).
10d0: 0a 0a 3b 20 28 64 6f 2d 65 63 3a 64 6f 20 63 6d ..; (do-ec:do cm
10e0: 64 20 28 3a 64 6f 20 6f 6c 65 74 20 6c 62 73 20 d (:do olet lbs
10f0: 6e 65 31 3f 20 69 6c 65 74 20 6e 65 32 3f 20 6c ne1? ilet ne2? l
1100: 73 73 29 29 0a 3b 20 20 20 67 65 6e 65 72 61 74 ss)).; generat
1110: 65 73 20 63 6f 64 65 20 66 6f 72 20 61 20 73 69 es code for a si
1120: 6e 67 6c 65 20 66 75 6c 6c 79 20 64 65 63 6f 72 ngle fully decor
1130: 61 74 65 64 20 3a 64 6f 2d 67 65 6e 65 72 61 74 ated :do-generat
1140: 6f 72 0a 3b 20 20 20 77 69 74 68 20 63 6d 64 20 or.; with cmd
1150: 61 73 20 70 61 79 6c 6f 61 64 2c 20 74 61 6b 69 as payload, taki
1160: 6e 67 20 63 61 72 65 20 6f 66 20 73 70 65 63 69 ng care of speci
1170: 61 6c 20 63 61 73 65 73 2e 0a 0a 28 64 65 66 69 al cases...(defi
1180: 6e 65 2d 73 79 6e 74 61 78 20 64 6f 2d 65 63 3a ne-syntax do-ec:
1190: 64 6f 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c do. (syntax-rul
11a0: 65 73 20 28 3a 64 6f 20 6c 65 74 29 0a 0a 20 20 es (:do let)..
11b0: 20 20 3b 20 72 65 65 6e 74 72 79 20 70 6f 69 6e ; reentry poin
11c0: 74 20 28 2a 29 20 2d 3e 20 67 65 6e 65 72 61 74 t (*) -> generat
11d0: 65 20 63 6f 64 65 0a 20 20 20 20 28 28 64 6f 2d e code. ((do-
11e0: 65 63 3a 64 6f 20 63 6d 64 20 0a 20 20 20 20 20 ec:do cmd .
11f0: 20 20 20 20 20 20 20 20 20 20 28 3a 64 6f 20 28 (:do (
1200: 6c 65 74 20 6f 62 73 20 6f 63 20 2e 2e 2e 29 20 let obs oc ...)
1210: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1220: 20 20 20 20 20 6c 62 73 20 0a 20 20 20 20 20 20 lbs .
1230: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 ne
1240: 31 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 1? .
1250: 20 20 20 20 20 20 20 20 28 6c 65 74 20 69 62 73 (let ibs
1260: 20 69 63 20 2e 2e 2e 29 20 0a 20 20 20 20 20 20 ic ...) .
1270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 ne
1280: 32 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 2? .
1290: 20 20 20 20 20 20 20 20 28 6c 73 20 2e 2e 2e 29 (ls ...)
12a0: 20 29 29 0a 20 20 20 20 20 28 65 63 2d 73 69 6d )). (ec-sim
12b0: 70 6c 69 66 79 0a 20 20 20 20 20 20 20 28 6c 65 plify. (le
12c0: 74 20 6f 62 73 0a 20 20 20 20 20 20 20 20 20 6f t obs. o
12d0: 63 20 2e 2e 2e 0a 20 20 20 20 20 20 20 20 20 28 c .... (
12e0: 6c 65 74 20 6c 6f 6f 70 20 6c 62 73 0a 20 20 20 let loop lbs.
12f0: 20 20 20 20 20 20 20 20 28 65 63 2d 73 69 6d 70 (ec-simp
1300: 6c 69 66 79 0a 20 20 20 20 20 20 20 20 20 20 20 lify.
1310: 20 20 28 69 66 20 6e 65 31 3f 0a 20 20 20 20 20 (if ne1?.
1320: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 63 2d (ec-
1330: 73 69 6d 70 6c 69 66 79 0a 20 20 20 20 20 20 20 simplify.
1340: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
1350: 20 69 62 73 0a 20 20 20 20 20 20 20 20 20 20 20 ibs.
1360: 20 20 20 20 20 20 20 20 20 20 20 69 63 20 2e 2e ic ..
1370: 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ..
1380: 20 20 20 20 20 20 20 20 63 6d 64 0a 20 20 20 20 cmd.
1390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13a0: 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 0a 20 (ec-simplify.
13b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13c0: 20 20 20 20 20 20 20 28 69 66 20 6e 65 32 3f 0a (if ne2?.
13d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
13e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
13f0: 70 20 6c 73 20 2e 2e 2e 29 20 29 29 29 29 29 29 p ls ...) ))))))
1400: 29 29 29 29 20 29 29 0a 0a 20 20 20 20 0a 3b 20 )))) )).. .;
1410: 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 3c 65 78 (ec-simplify <ex
1420: 70 72 65 73 73 69 6f 6e 3e 29 0a 3b 20 20 20 67 pression>).; g
1430: 65 6e 65 72 61 74 65 73 20 70 6f 74 65 6e 74 69 enerates potenti
1440: 61 6c 6c 79 20 6d 6f 72 65 20 65 66 66 69 63 69 ally more effici
1450: 65 6e 74 20 63 6f 64 65 20 66 6f 72 20 3c 65 78 ent code for <ex
1460: 70 72 65 73 73 69 6f 6e 3e 2e 0a 3b 20 20 20 54 pression>..; T
1470: 68 65 20 6d 61 63 72 6f 20 68 61 6e 64 6c 65 73 he macro handles
1480: 20 69 66 2c 20 28 62 65 67 69 6e 20 3c 63 6f 6d if, (begin <com
1490: 6d 61 6e 64 3e 2a 29 2c 20 61 6e 64 20 28 6c 65 mand>*), and (le
14a0: 74 20 28 29 20 3c 63 6f 6d 6d 61 6e 64 3e 2a 29 t () <command>*)
14b0: 0a 3b 20 20 20 61 6e 64 20 74 61 6b 65 73 20 63 .; and takes c
14c0: 61 72 65 20 6f 66 20 73 70 65 63 69 61 6c 20 63 are of special c
14d0: 61 73 65 73 2e 0a 0a 28 64 65 66 69 6e 65 2d 73 ases...(define-s
14e0: 79 6e 74 61 78 20 65 63 2d 73 69 6d 70 6c 69 66 yntax ec-simplif
14f0: 79 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 y. (syntax-rule
1500: 73 20 28 69 66 20 6e 6f 74 20 6c 65 74 20 62 65 s (if not let be
1510: 67 69 6e 29 0a 0a 3b 20 6f 6e 65 2d 20 61 6e 64 gin)..; one- and
1520: 20 74 77 6f 2d 73 69 64 65 64 20 69 66 0a 0a 20 two-sided if..
1530: 20 20 20 3b 20 6c 69 74 65 72 61 6c 20 3c 74 65 ; literal <te
1540: 73 74 3e 0a 20 20 20 20 28 28 65 63 2d 73 69 6d st>. ((ec-sim
1550: 70 6c 69 66 79 20 28 69 66 20 23 74 20 63 6f 6e plify (if #t con
1560: 73 65 71 75 65 6e 74 29 29 0a 20 20 20 20 20 63 sequent)). c
1570: 6f 6e 73 65 71 75 65 6e 74 20 29 0a 20 20 20 20 onsequent ).
1580: 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 28 69 ((ec-simplify (i
1590: 66 20 23 66 20 63 6f 6e 73 65 71 75 65 6e 74 29 f #f consequent)
15a0: 29 0a 20 20 20 20 20 28 69 66 20 23 66 20 23 66 ). (if #f #f
15b0: 29 20 29 0a 20 20 20 20 28 28 65 63 2d 73 69 6d ) ). ((ec-sim
15c0: 70 6c 69 66 79 20 28 69 66 20 23 74 20 63 6f 6e plify (if #t con
15d0: 73 65 71 75 65 6e 74 20 61 6c 74 65 72 6e 61 74 sequent alternat
15e0: 65 29 29 0a 20 20 20 20 20 63 6f 6e 73 65 71 75 e)). consequ
15f0: 65 6e 74 20 29 0a 20 20 20 20 28 28 65 63 2d 73 ent ). ((ec-s
1600: 69 6d 70 6c 69 66 79 20 28 69 66 20 23 66 20 63 implify (if #f c
1610: 6f 6e 73 65 71 75 65 6e 74 20 61 6c 74 65 72 6e onsequent altern
1620: 61 74 65 29 29 0a 20 20 20 20 20 61 6c 74 65 72 ate)). alter
1630: 6e 61 74 65 20 29 0a 0a 20 20 20 20 3b 20 28 6e nate ).. ; (n
1640: 6f 74 20 28 6e 6f 74 20 3c 74 65 73 74 3e 29 29 ot (not <test>))
1650: 0a 20 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 . ((ec-simpli
1660: 66 79 20 28 69 66 20 28 6e 6f 74 20 28 6e 6f 74 fy (if (not (not
1670: 20 74 65 73 74 29 29 20 63 6f 6e 73 65 71 75 65 test)) conseque
1680: 6e 74 29 29 0a 20 20 20 20 20 28 65 63 2d 73 69 nt)). (ec-si
1690: 6d 70 6c 69 66 79 20 28 69 66 20 74 65 73 74 20 mplify (if test
16a0: 63 6f 6e 73 65 71 75 65 6e 74 29 29 20 29 0a 20 consequent)) ).
16b0: 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 ((ec-simplify
16c0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 6f 74 20 74 (if (not (not t
16d0: 65 73 74 29 29 20 63 6f 6e 73 65 71 75 65 6e 74 est)) consequent
16e0: 20 61 6c 74 65 72 6e 61 74 65 29 29 0a 20 20 20 alternate)).
16f0: 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 28 (ec-simplify (
1700: 69 66 20 74 65 73 74 20 63 6f 6e 73 65 71 75 65 if test conseque
1710: 6e 74 20 61 6c 74 65 72 6e 61 74 65 29 29 20 29 nt alternate)) )
1720: 0a 0a 3b 20 28 6c 65 74 20 28 29 20 3c 63 6f 6d ..; (let () <com
1730: 6d 61 6e 64 3e 2a 29 20 0a 0a 20 20 20 20 3b 20 mand>*) .. ;
1740: 65 6d 70 74 79 20 3c 62 69 6e 64 69 6e 67 20 73 empty <binding s
1750: 70 65 63 3e 2a 0a 20 20 20 20 28 28 65 63 2d 73 pec>*. ((ec-s
1760: 69 6d 70 6c 69 66 79 20 28 6c 65 74 20 28 29 20 implify (let ()
1770: 63 6f 6d 6d 61 6e 64 20 2e 2e 2e 29 29 0a 20 20 command ...)).
1780: 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 (ec-simplify
1790: 28 62 65 67 69 6e 20 63 6f 6d 6d 61 6e 64 20 2e (begin command .
17a0: 2e 2e 29 29 20 29 0a 0a 3b 20 62 65 67 69 6e 20 ..)) )..; begin
17b0: 0a 0a 20 20 20 20 3b 20 66 6c 61 74 74 65 6e 20 .. ; flatten
17c0: 75 73 65 20 68 65 6c 70 65 72 20 28 65 63 2d 73 use helper (ec-s
17d0: 69 6d 70 6c 69 66 79 20 31 20 64 6f 6e 65 20 74 implify 1 done t
17e0: 6f 2d 64 6f 29 0a 20 20 20 20 28 28 65 63 2d 73 o-do). ((ec-s
17f0: 69 6d 70 6c 69 66 79 20 28 62 65 67 69 6e 20 63 implify (begin c
1800: 6f 6d 6d 61 6e 64 20 2e 2e 2e 29 29 0a 20 20 20 ommand ...)).
1810: 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 31 (ec-simplify 1
1820: 20 28 29 20 28 63 6f 6d 6d 61 6e 64 20 2e 2e 2e () (command ...
1830: 29 29 20 29 0a 20 20 20 20 28 28 65 63 2d 73 69 )) ). ((ec-si
1840: 6d 70 6c 69 66 79 20 31 20 64 6f 6e 65 20 28 28 mplify 1 done ((
1850: 62 65 67 69 6e 20 74 6f 2d 64 6f 31 20 2e 2e 2e begin to-do1 ...
1860: 29 20 74 6f 2d 64 6f 32 20 2e 2e 2e 29 29 0a 20 ) to-do2 ...)).
1870: 20 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 (ec-simplify
1880: 20 31 20 64 6f 6e 65 20 28 74 6f 2d 64 6f 31 20 1 done (to-do1
1890: 2e 2e 2e 20 74 6f 2d 64 6f 32 20 2e 2e 2e 29 29 ... to-do2 ...))
18a0: 20 29 0a 20 20 20 20 28 28 65 63 2d 73 69 6d 70 ). ((ec-simp
18b0: 6c 69 66 79 20 31 20 28 64 6f 6e 65 20 2e 2e 2e lify 1 (done ...
18c0: 29 20 28 74 6f 2d 64 6f 31 20 74 6f 2d 64 6f 20 ) (to-do1 to-do
18d0: 2e 2e 2e 29 29 0a 20 20 20 20 20 28 65 63 2d 73 ...)). (ec-s
18e0: 69 6d 70 6c 69 66 79 20 31 20 28 64 6f 6e 65 20 implify 1 (done
18f0: 2e 2e 2e 20 74 6f 2d 64 6f 31 29 20 28 74 6f 2d ... to-do1) (to-
1900: 64 6f 20 2e 2e 2e 29 29 20 29 0a 0a 20 20 20 20 do ...)) )..
1910: 3b 20 65 78 69 74 20 68 65 6c 70 65 72 0a 20 20 ; exit helper.
1920: 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 ((ec-simplify
1930: 31 20 28 29 20 28 29 29 0a 20 20 20 20 20 28 69 1 () ()). (i
1940: 66 20 23 66 20 23 66 29 20 29 0a 20 20 20 20 28 f #f #f) ). (
1950: 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 31 20 28 (ec-simplify 1 (
1960: 63 6f 6d 6d 61 6e 64 29 20 28 29 29 0a 20 20 20 command) ()).
1970: 20 20 63 6f 6d 6d 61 6e 64 20 29 0a 20 20 20 20 command ).
1980: 28 28 65 63 2d 73 69 6d 70 6c 69 66 79 20 31 20 ((ec-simplify 1
1990: 28 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 28 29 29 0a 20 20 20 20 20 d ...) ()).
19b0: 28 62 65 67 69 6e 20 63 6f 6d 6d 61 6e 64 31 20 (begin command1
19c0: 63 6f 6d 6d 61 6e 64 20 2e 2e 2e 29 20 29 0a 0a command ...) )..
19d0: 3b 20 61 6e 79 74 68 69 6e 67 20 65 6c 73 65 0a ; anything else.
19e0: 0a 20 20 20 20 28 28 65 63 2d 73 69 6d 70 6c 69 . ((ec-simpli
19f0: 66 79 20 65 78 70 72 65 73 73 69 6f 6e 29 0a 20 fy expression).
1a00: 20 20 20 20 65 78 70 72 65 73 73 69 6f 6e 20 29 expression )
1a10: 29 29 0a 0a 0a 3b 20 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 3d 3d 3d 3d 3d ================
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 0a 3b 20 54 68 65 20 73 70 65 63 69 61 6c 20 =.; The special
1a70: 67 65 6e 65 72 61 74 6f 72 73 20 3a 64 6f 2c 20 generators :do,
1a80: 3a 6c 65 74 2c 20 3a 70 61 72 61 6c 6c 65 6c 2c :let, :parallel,
1a90: 20 3a 77 68 69 6c 65 2c 20 61 6e 64 20 3a 75 6e :while, and :un
1aa0: 74 69 6c 0a 3b 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d til.; ==========
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 3d 3d 3d 3d 3d 3d ================
1ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1af0: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
1b00: 20 3a 64 6f 0a 20 20 28 73 79 6e 74 61 78 2d 72 :do. (syntax-r
1b10: 75 6c 65 73 20 28 29 0a 0a 20 20 20 20 3b 20 66 ules ().. ; f
1b20: 75 6c 6c 20 64 65 63 6f 72 61 74 65 64 20 2d 3e ull decorated ->
1b30: 20 63 6f 6e 74 69 6e 75 65 20 77 69 74 68 20 63 continue with c
1b40: 63 2c 20 72 65 65 6e 74 72 79 20 61 74 20 28 2a c, reentry at (*
1b50: 29 0a 20 20 20 20 28 28 3a 64 6f 20 28 63 63 20 ). ((:do (cc
1b60: 2e 2e 2e 29 20 6f 6c 65 74 20 6c 62 73 20 6e 65 ...) olet lbs ne
1b70: 31 3f 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 73 1? ilet ne2? lss
1b80: 29 0a 20 20 20 20 20 28 63 63 20 2e 2e 2e 20 28 ). (cc ... (
1b90: 3a 64 6f 20 6f 6c 65 74 20 6c 62 73 20 6e 65 31 :do olet lbs ne1
1ba0: 3f 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 73 29 ? ilet ne2? lss)
1bb0: 29 20 29 0a 0a 20 20 20 20 3b 20 73 68 6f 72 74 ) ).. ; short
1bc0: 20 66 6f 72 6d 20 2d 3e 20 66 69 6c 6c 20 69 6e form -> fill in
1bd0: 20 64 65 66 61 75 6c 74 20 76 61 6c 75 65 73 0a default values.
1be0: 20 20 20 20 28 28 3a 64 6f 20 63 63 20 6c 62 73 ((:do cc lbs
1bf0: 20 6e 65 31 3f 20 6c 73 73 29 0a 20 20 20 20 20 ne1? lss).
1c00: 28 3a 64 6f 20 63 63 20 28 6c 65 74 20 28 29 29 (:do cc (let ())
1c10: 20 6c 62 73 20 6e 65 31 3f 20 28 6c 65 74 20 28 lbs ne1? (let (
1c20: 29 29 20 23 74 20 6c 73 73 29 20 29 29 29 0a 20 )) #t lss) ))).
1c30: 20 20 20 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e ..(define-syn
1c40: 74 61 78 20 3a 6c 65 74 0a 20 20 28 73 79 6e 74 tax :let. (synt
1c50: 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 65 78 29 ax-rules (index)
1c60: 0a 20 20 20 20 28 28 3a 6c 65 74 20 63 63 20 76 . ((:let cc v
1c70: 61 72 20 28 69 6e 64 65 78 20 69 29 20 65 78 70 ar (index i) exp
1c80: 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 3a ression). (:
1c90: 64 6f 20 63 63 20 28 6c 65 74 20 28 28 76 61 72 do cc (let ((var
1ca0: 20 65 78 70 72 65 73 73 69 6f 6e 29 20 28 69 20 expression) (i
1cb0: 30 29 29 29 20 28 29 20 23 74 20 28 6c 65 74 20 0))) () #t (let
1cc0: 28 29 29 20 23 66 20 28 29 29 20 29 0a 20 20 20 ()) #f ()) ).
1cd0: 20 28 28 3a 6c 65 74 20 63 63 20 76 61 72 20 65 ((:let cc var e
1ce0: 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 xpression).
1cf0: 28 3a 64 6f 20 63 63 20 28 6c 65 74 20 28 28 76 (:do cc (let ((v
1d00: 61 72 20 65 78 70 72 65 73 73 69 6f 6e 29 29 29 ar expression)))
1d10: 20 28 29 20 23 74 20 28 6c 65 74 20 28 29 29 20 () #t (let ())
1d20: 23 66 20 28 29 29 20 29 29 29 0a 0a 0a 28 64 65 #f ()) )))...(de
1d30: 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a 70 61 72 fine-syntax :par
1d40: 61 6c 6c 65 6c 0a 20 20 28 73 79 6e 74 61 78 2d allel. (syntax-
1d50: 72 75 6c 65 73 20 28 3a 64 6f 29 0a 20 20 20 20 rules (:do).
1d60: 28 28 3a 70 61 72 61 6c 6c 65 6c 20 63 63 29 0a ((:parallel cc).
1d70: 20 20 20 20 20 63 63 20 29 0a 20 20 20 20 28 28 cc ). ((
1d80: 3a 70 61 72 61 6c 6c 65 6c 20 63 63 20 28 67 20 :parallel cc (g
1d90: 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 20 67 65 arg1 arg ...) ge
1da0: 6e 20 2e 2e 2e 29 0a 20 20 20 20 20 28 67 20 28 n ...). (g (
1db0: 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 63 63 20 28 :parallel-1 cc (
1dc0: 67 65 6e 20 2e 2e 2e 29 29 20 61 72 67 31 20 61 gen ...)) arg1 a
1dd0: 72 67 20 2e 2e 2e 29 20 29 29 29 0a 0a 3b 20 28 rg ...) )))..; (
1de0: 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 63 63 20 28 :parallel-1 cc (
1df0: 74 6f 2d 64 6f 20 2e 2e 2e 29 20 72 65 73 75 6c to-do ...) resul
1e00: 74 20 5b 20 6e 65 78 74 20 5d 20 29 0a 3b 20 20 t [ next ] ).;
1e10: 20 20 69 74 65 72 61 74 65 73 20 6f 76 65 72 20 iterates over
1e20: 74 6f 2d 64 6f 20 62 79 20 63 6f 6e 76 65 72 74 to-do by convert
1e30: 69 6e 67 20 74 68 65 20 66 69 72 73 74 20 67 65 ing the first ge
1e40: 6e 65 72 61 74 6f 72 20 69 6e 74 6f 20 0a 3b 20 nerator into .;
1e50: 20 20 20 74 68 65 20 3a 64 6f 2d 67 65 6e 65 72 the :do-gener
1e60: 61 74 6f 72 20 6e 65 78 74 20 61 6e 64 20 6d 65 ator next and me
1e70: 72 67 69 6e 67 20 6e 65 78 74 20 69 6e 74 6f 20 rging next into
1e80: 72 65 73 75 6c 74 2e 0a 0a 28 64 65 66 69 6e 65 result...(define
1e90: 2d 73 79 6e 74 61 78 20 3a 70 61 72 61 6c 6c 65 -syntax :paralle
1ea0: 6c 2d 31 20 20 3b 20 75 73 65 64 20 61 73 20 0a l-1 ; used as .
1eb0: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
1ec0: 28 3a 64 6f 20 6c 65 74 29 0a 0a 20 20 20 20 3b (:do let).. ;
1ed0: 20 70 72 6f 63 65 73 73 20 6e 65 78 74 20 65 6c process next el
1ee0: 65 6d 65 6e 74 20 6f 66 20 74 6f 2d 64 6f 2c 20 ement of to-do,
1ef0: 72 65 65 6e 74 72 79 20 61 74 20 28 2a 2a 29 0a reentry at (**).
1f00: 20 20 20 20 28 28 3a 70 61 72 61 6c 6c 65 6c 2d ((:parallel-
1f10: 31 20 63 63 20 28 28 67 20 61 72 67 31 20 61 72 1 cc ((g arg1 ar
1f20: 67 20 2e 2e 2e 29 20 67 65 6e 20 2e 2e 2e 29 20 g ...) gen ...)
1f30: 72 65 73 75 6c 74 29 0a 20 20 20 20 20 28 67 20 result). (g
1f40: 28 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 63 63 20 (:parallel-1 cc
1f50: 28 67 65 6e 20 2e 2e 2e 29 20 72 65 73 75 6c 74 (gen ...) result
1f60: 29 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 20 ) arg1 arg ...)
1f70: 29 0a 0a 20 20 20 20 3b 20 72 65 65 6e 74 72 79 ).. ; reentry
1f80: 20 70 6f 69 6e 74 20 28 2a 2a 29 20 2d 3e 20 6d point (**) -> m
1f90: 65 72 67 65 20 6e 65 78 74 20 69 6e 74 6f 20 72 erge next into r
1fa0: 65 73 75 6c 74 0a 20 20 20 20 28 28 3a 70 61 72 esult. ((:par
1fb0: 61 6c 6c 65 6c 2d 31 20 0a 20 20 20 20 20 20 20 allel-1 .
1fc0: 63 63 20 0a 20 20 20 20 20 20 20 67 65 6e 73 20 cc . gens
1fd0: 0a 20 20 20 20 20 20 20 28 3a 64 6f 20 28 6c 65 . (:do (le
1fe0: 74 20 28 6f 62 31 20 2e 2e 2e 29 20 6f 63 31 20 t (ob1 ...) oc1
1ff0: 2e 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 ...) .
2000: 20 20 28 6c 62 31 20 2e 2e 2e 29 20 0a 20 20 20 (lb1 ...) .
2010: 20 20 20 20 20 20 20 20 20 6e 65 31 3f 31 20 0a ne1?1 .
2020: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
2030: 20 28 69 62 31 20 2e 2e 2e 29 20 69 63 31 20 2e (ib1 ...) ic1 .
2040: 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ..) .
2050: 20 6e 65 32 3f 31 20 0a 20 20 20 20 20 20 20 20 ne2?1 .
2060: 20 20 20 20 28 6c 73 31 20 2e 2e 2e 29 20 29 0a (ls1 ...) ).
2070: 20 20 20 20 20 20 20 28 3a 64 6f 20 28 6c 65 74 (:do (let
2080: 20 28 6f 62 32 20 2e 2e 2e 29 20 6f 63 32 20 2e (ob2 ...) oc2 .
2090: 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 ..) .
20a0: 20 28 6c 62 32 20 2e 2e 2e 29 20 0a 20 20 20 20 (lb2 ...) .
20b0: 20 20 20 20 20 20 20 20 6e 65 31 3f 32 20 0a 20 ne1?2 .
20c0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
20d0: 28 69 62 32 20 2e 2e 2e 29 20 69 63 32 20 2e 2e (ib2 ...) ic2 ..
20e0: 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .) .
20f0: 6e 65 32 3f 32 20 0a 20 20 20 20 20 20 20 20 20 ne2?2 .
2100: 20 20 20 28 6c 73 32 20 2e 2e 2e 29 20 29 29 0a (ls2 ...) )).
2110: 20 20 20 20 20 28 3a 70 61 72 61 6c 6c 65 6c 2d (:parallel-
2120: 31 20 0a 20 20 20 20 20 20 20 63 63 20 0a 20 20 1 . cc .
2130: 20 20 20 20 20 67 65 6e 73 20 0a 20 20 20 20 20 gens .
2140: 20 20 28 3a 64 6f 20 28 6c 65 74 20 28 6f 62 31 (:do (let (ob1
2150: 20 2e 2e 2e 20 6f 62 32 20 2e 2e 2e 29 20 6f 63 ... ob2 ...) oc
2160: 31 20 2e 2e 2e 20 6f 63 32 20 2e 2e 2e 29 20 0a 1 ... oc2 ...) .
2170: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 62 31 (lb1
2180: 20 2e 2e 2e 20 6c 62 32 20 2e 2e 2e 29 20 0a 20 ... lb2 ...) .
2190: 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 (and
21a0: 6e 65 31 3f 31 20 6e 65 31 3f 32 29 20 0a 20 20 ne1?1 ne1?2) .
21b0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
21c0: 69 62 31 20 2e 2e 2e 20 69 62 32 20 2e 2e 2e 29 ib1 ... ib2 ...)
21d0: 20 69 63 31 20 2e 2e 2e 20 69 63 32 20 2e 2e 2e ic1 ... ic2 ...
21e0: 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 ) . (
21f0: 61 6e 64 20 6e 65 32 3f 31 20 6e 65 32 3f 32 29 and ne2?1 ne2?2)
2200: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c . (l
2210: 73 31 20 2e 2e 2e 20 6c 73 32 20 2e 2e 2e 29 20 s1 ... ls2 ...)
2220: 29 29 29 0a 0a 20 20 20 20 3b 20 6e 6f 20 6d 6f ))).. ; no mo
2230: 72 65 20 67 65 6e 73 20 2d 3e 20 63 6f 6e 74 69 re gens -> conti
2240: 6e 75 65 20 77 69 74 68 20 63 63 2c 20 72 65 65 nue with cc, ree
2250: 6e 74 72 79 20 61 74 20 28 2a 29 0a 20 20 20 20 ntry at (*).
2260: 28 28 3a 70 61 72 61 6c 6c 65 6c 2d 31 20 28 63 ((:parallel-1 (c
2270: 63 20 2e 2e 2e 29 20 28 29 20 72 65 73 75 6c 74 c ...) () result
2280: 29 0a 20 20 20 20 20 28 63 63 20 2e 2e 2e 20 72 ). (cc ... r
2290: 65 73 75 6c 74 29 20 29 29 29 0a 0a 28 64 65 66 esult) )))..(def
22a0: 69 6e 65 2d 73 79 6e 74 61 78 20 3a 77 68 69 6c ine-syntax :whil
22b0: 65 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 e. (syntax-rule
22c0: 73 20 28 29 0a 20 20 20 20 28 28 3a 77 68 69 6c s (). ((:whil
22d0: 65 20 63 63 20 28 67 20 61 72 67 31 20 61 72 67 e cc (g arg1 arg
22e0: 20 2e 2e 2e 29 20 74 65 73 74 29 0a 20 20 20 20 ...) test).
22f0: 20 28 67 20 28 3a 77 68 69 6c 65 2d 31 20 63 63 (g (:while-1 cc
2300: 20 74 65 73 74 29 20 61 72 67 31 20 61 72 67 20 test) arg1 arg
2310: 2e 2e 2e 29 20 29 29 29 0a 0a 3b 20 28 3a 77 68 ...) )))..; (:wh
2320: 69 6c 65 2d 31 20 63 63 20 74 65 73 74 20 28 3a ile-1 cc test (:
2330: 64 6f 20 2e 2e 2e 29 29 0a 3b 20 20 20 20 6d 6f do ...)).; mo
2340: 64 69 66 69 65 73 20 74 68 65 20 66 75 6c 6c 79 difies the fully
2350: 20 64 65 63 6f 72 61 74 65 64 20 3a 64 6f 2d 67 decorated :do-g
2360: 65 6e 65 72 61 74 6f 72 20 73 75 63 68 20 74 68 enerator such th
2370: 61 74 20 69 74 0a 3b 20 20 20 20 72 75 6e 73 20 at it.; runs
2380: 77 68 69 6c 65 20 74 65 73 74 20 69 73 20 61 20 while test is a
2390: 74 72 75 65 20 76 61 6c 75 65 2e 20 0a 3b 20 20 true value. .;
23a0: 20 20 20 20 20 54 68 65 20 6f 72 69 67 69 6e 61 The origina
23b0: 6c 20 69 6d 70 6c 65 6d 65 6e 74 61 74 69 6f 6e l implementation
23c0: 20 6a 75 73 74 20 72 65 70 6c 61 63 65 64 20 6e just replaced n
23d0: 65 31 3f 20 62 79 0a 3b 20 20 20 20 28 61 6e 64 e1? by.; (and
23e0: 20 6e 65 31 3f 20 74 65 73 74 29 20 61 73 20 66 ne1? test) as f
23f0: 6f 6c 6c 6f 77 73 3a 0a 3b 0a 3b 20 20 20 20 20 ollows:.;.;
2400: 20 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 (define-syntax
2410: 3a 77 68 69 6c 65 2d 31 0a 3b 20 20 20 20 20 20 :while-1.;
2420: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
2430: 28 3a 64 6f 29 0a 3b 20 20 20 20 20 20 20 20 20 (:do).;
2440: 20 28 28 3a 77 68 69 6c 65 2d 31 20 63 63 20 74 ((:while-1 cc t
2450: 65 73 74 20 28 3a 64 6f 20 6f 6c 65 74 20 6c 62 est (:do olet lb
2460: 73 20 6e 65 31 3f 20 69 6c 65 74 20 6e 65 32 3f s ne1? ilet ne2?
2470: 20 6c 73 73 29 29 0a 3b 20 20 20 20 20 20 20 20 lss)).;
2480: 20 20 20 28 3a 64 6f 20 63 63 20 6f 6c 65 74 20 (:do cc olet
2490: 6c 62 73 20 28 61 6e 64 20 6e 65 31 3f 20 74 65 lbs (and ne1? te
24a0: 73 74 29 20 69 6c 65 74 20 6e 65 32 3f 20 6c 73 st) ilet ne2? ls
24b0: 73 29 20 29 29 29 0a 3b 0a 3b 20 20 20 20 55 6e s) ))).;.; Un
24c0: 66 6f 72 74 75 6e 61 74 65 6c 79 2c 20 74 68 69 fortunately, thi
24d0: 73 20 63 6f 64 65 20 69 73 20 77 72 6f 6e 67 20 s code is wrong
24e0: 62 65 63 61 75 73 65 20 6e 65 31 3f 20 6d 61 79 because ne1? may
24f0: 20 64 65 70 65 6e 64 0a 3b 20 20 20 20 69 6e 20 depend.; in
2500: 74 68 65 20 69 6e 6e 65 72 20 62 69 6e 64 69 6e the inner bindin
2510: 67 73 20 69 6e 74 72 6f 64 75 63 65 64 20 69 6e gs introduced in
2520: 20 69 6c 65 74 2c 20 62 75 74 20 6e 65 31 3f 20 ilet, but ne1?
2530: 69 73 20 65 76 61 6c 75 61 74 65 64 0a 3b 20 20 is evaluated.;
2540: 20 20 6f 75 74 73 69 64 65 20 6f 66 20 74 68 65 outside of the
2550: 20 69 6e 6e 65 72 20 62 69 6e 64 69 6e 67 73 2e inner bindings.
2560: 20 28 52 65 66 65 72 20 74 6f 20 74 68 65 20 73 (Refer to the s
2570: 70 65 63 69 66 69 63 61 74 69 6f 6e 20 6f 66 0a pecification of.
2580: 3b 20 20 20 20 3a 64 6f 20 74 6f 20 73 65 65 20 ; :do to see
2590: 74 68 65 20 73 74 72 75 63 74 75 72 65 2e 29 20 the structure.)
25a0: 0a 3b 20 20 20 20 20 20 20 54 68 65 20 70 72 6f .; The pro
25b0: 62 6c 65 6d 20 6d 61 6e 69 66 65 73 74 73 20 69 blem manifests i
25c0: 74 73 65 6c 66 20 28 61 73 20 73 75 6e 6e 61 6e tself (as sunnan
25d0: 40 68 61 6e 64 67 72 61 6e 61 74 2e 6f 72 67 20 @handgranat.org
25e0: 0a 3b 20 20 20 20 6f 62 73 65 72 76 65 64 29 20 .; observed)
25f0: 77 68 65 6e 20 74 68 65 20 3a 6c 69 73 74 2d 67 when the :list-g
2600: 65 6e 65 72 61 74 6f 72 20 69 73 20 6d 6f 64 69 enerator is modi
2610: 66 69 65 64 3a 0a 3b 20 0a 3b 20 20 20 20 20 20 fied:.; .;
2620: 28 64 6f 2d 65 63 20 28 3a 77 68 69 6c 65 20 28 (do-ec (:while (
2630: 3a 6c 69 73 74 20 78 20 27 28 31 20 32 29 29 20 :list x '(1 2))
2640: 28 3d 20 78 20 31 29 29 20 28 64 69 73 70 6c 61 (= x 1)) (displa
2650: 79 20 78 29 29 2e 0a 3b 0a 3b 20 20 20 20 49 6e y x))..;.; In
2660: 20 6f 72 64 65 72 20 74 6f 20 67 65 6e 65 72 61 order to genera
2670: 74 65 20 70 72 6f 70 65 72 20 63 6f 64 65 2c 20 te proper code,
2680: 77 65 20 69 6e 74 72 6f 64 75 63 65 20 74 65 6d we introduce tem
2690: 70 6f 72 61 72 79 0a 3b 20 20 20 20 76 61 72 69 porary.; vari
26a0: 61 62 6c 65 73 20 73 61 76 69 6e 67 20 74 68 65 ables saving the
26b0: 20 76 61 6c 75 65 73 20 6f 66 20 74 68 65 20 69 values of the i
26c0: 6e 6e 65 72 20 62 69 6e 64 69 6e 67 73 2e 20 54 nner bindings. T
26d0: 68 65 20 69 6e 6e 65 72 0a 3b 20 20 20 20 62 69 he inner.; bi
26e0: 6e 64 69 6e 67 73 20 61 72 65 20 65 78 65 63 75 ndings are execu
26f0: 74 65 64 20 69 6e 20 61 20 6e 65 77 20 6e 65 31 ted in a new ne1
2700: 3f 2c 20 77 68 69 63 68 20 61 6c 73 6f 20 65 76 ?, which also ev
2710: 61 6c 75 61 74 65 73 20 6e 65 31 3f 0a 3b 20 20 aluates ne1?.;
2720: 20 20 6f 75 74 73 69 64 65 20 74 68 65 20 73 63 outside the sc
2730: 6f 70 65 20 6f 66 20 74 68 65 20 69 6e 6e 65 72 ope of the inner
2740: 20 62 69 6e 64 69 6e 67 73 2c 20 74 68 65 6e 20 bindings, then
2750: 74 68 65 20 69 6e 6e 65 72 20 63 6f 6d 6d 61 6e the inner comman
2760: 64 73 0a 3b 20 20 20 20 61 72 65 20 65 78 65 63 ds.; are exec
2770: 75 74 65 64 20 28 70 6f 73 73 69 62 6c 79 20 63 uted (possibly c
2780: 68 61 6e 67 69 6e 67 20 74 68 65 20 76 61 72 69 hanging the vari
2790: 61 62 6c 65 73 29 2c 20 61 6e 64 20 74 68 65 6e ables), and then
27a0: 20 74 68 65 0a 3b 20 20 20 20 76 61 6c 75 65 73 the.; values
27b0: 20 6f 66 20 74 68 65 20 69 6e 6e 65 72 20 62 69 of the inner bi
27c0: 6e 64 69 6e 67 73 20 61 72 65 20 73 61 76 65 64 ndings are saved
27d0: 20 61 6e 64 20 28 61 6e 64 20 6e 65 31 3f 20 74 and (and ne1? t
27e0: 65 73 74 29 20 69 73 0a 3b 20 20 20 20 72 65 74 est) is.; ret
27f0: 75 72 6e 65 64 2e 20 49 6e 20 74 68 65 20 6e 65 urned. In the ne
2800: 77 20 69 6c 65 74 2c 20 74 68 65 20 69 6e 6e 65 w ilet, the inne
2810: 72 20 76 61 72 69 61 62 6c 65 73 20 61 72 65 20 r variables are
2820: 62 6f 75 6e 64 20 61 6e 64 0a 3b 20 20 20 20 69 bound and.; i
2830: 6e 69 74 69 61 6c 69 7a 65 64 20 61 6e 64 20 74 nitialized and t
2840: 68 65 69 72 20 76 61 6c 75 65 73 20 61 72 65 20 heir values are
2850: 72 65 73 74 6f 72 65 64 2e 20 53 6f 20 77 65 20 restored. So we
2860: 63 6f 6e 73 74 72 75 63 74 3a 0a 3b 0a 3b 20 20 construct:.;.;
2870: 20 20 20 28 6c 65 74 20 28 6f 62 20 2e 2e 20 28 (let (ob .. (
2880: 69 62 2d 74 6d 70 20 23 66 29 20 2e 2e 2e 29 0a ib-tmp #f) ...).
2890: 3b 20 20 20 20 20 20 20 6f 63 20 2e 2e 2e 0a 3b ; oc ....;
28a0: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
28b0: 20 28 6c 62 20 2e 2e 2e 29 0a 3b 20 20 20 20 20 (lb ...).;
28c0: 20 20 20 20 28 69 66 20 28 6c 65 74 20 28 6e 65 (if (let (ne
28d0: 31 3f 2d 76 61 6c 75 65 20 6e 65 31 3f 29 0a 3b 1?-value ne1?).;
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
28f0: 6c 65 74 20 28 28 69 62 2d 76 61 72 20 69 62 2d let ((ib-var ib-
2900: 72 68 73 29 20 2e 2e 2e 29 0a 3b 20 20 20 20 20 rhs) ...).;
2910: 20 20 20 20 20 20 20 20 20 20 20 20 69 63 20 2e ic .
2920: 2e 2e 0a 3b 20 20 20 20 20 20 20 20 20 20 20 20 ...;
2930: 20 20 20 20 20 28 73 65 74 21 20 69 62 2d 74 6d (set! ib-tm
2940: 70 20 69 62 2d 76 61 72 29 20 2e 2e 2e 29 0a 3b p ib-var) ...).;
2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2960: 61 6e 64 20 6e 65 31 3f 2d 76 61 6c 75 65 20 74 and ne1?-value t
2970: 65 73 74 29 29 0a 3b 20 20 20 20 20 20 20 20 20 est)).;
2980: 20 20 20 20 28 6c 65 74 20 28 28 69 62 2d 76 61 (let ((ib-va
2990: 72 20 69 62 2d 74 6d 70 29 20 2e 2e 2e 29 0a 3b r ib-tmp) ...).;
29a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 2f /
29b0: 70 61 79 6c 6f 61 64 2f 0a 3b 20 20 20 20 20 20 payload/.;
29c0: 20 20 20 20 20 20 20 20 20 28 69 66 20 6e 65 32 (if ne2
29d0: 3f 0a 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ?.;
29e0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 6c 73 20 2e (loop ls .
29f0: 2e 2e 29 20 29 29 29 29 29 0a 0a 28 64 65 66 69 ..) )))))..(defi
2a00: 6e 65 2d 73 79 6e 74 61 78 20 3a 77 68 69 6c 65 ne-syntax :while
2a10: 2d 31 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c -1. (syntax-rul
2a20: 65 73 20 28 3a 64 6f 20 6c 65 74 29 0a 20 20 20 es (:do let).
2a30: 20 28 28 3a 77 68 69 6c 65 2d 31 20 63 63 20 74 ((:while-1 cc t
2a40: 65 73 74 20 28 3a 64 6f 20 6f 6c 65 74 20 6c 62 est (:do olet lb
2a50: 73 20 6e 65 31 3f 20 69 6c 65 74 20 6e 65 32 3f s ne1? ilet ne2?
2a60: 20 6c 73 73 29 29 0a 20 20 20 20 20 28 3a 77 68 lss)). (:wh
2a70: 69 6c 65 2d 32 20 63 63 20 74 65 73 74 20 28 29 ile-2 cc test ()
2a80: 20 28 29 20 28 29 20 28 3a 64 6f 20 6f 6c 65 74 () () (:do olet
2a90: 20 6c 62 73 20 6e 65 31 3f 20 69 6c 65 74 20 6e lbs ne1? ilet n
2aa0: 65 32 3f 20 6c 73 73 29 29 29 29 29 0a 0a 28 64 e2? lss)))))..(d
2ab0: 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a 77 68 efine-syntax :wh
2ac0: 69 6c 65 2d 32 0a 20 20 28 73 79 6e 74 61 78 2d ile-2. (syntax-
2ad0: 72 75 6c 65 73 20 28 3a 64 6f 20 6c 65 74 29 0a rules (:do let).
2ae0: 20 20 20 20 28 28 3a 77 68 69 6c 65 2d 32 20 63 ((:while-2 c
2af0: 63 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 c .
2b00: 20 20 74 65 73 74 20 0a 20 20 20 20 20 20 20 20 test .
2b10: 20 20 20 20 20 20 20 28 69 62 2d 6c 65 74 20 20 (ib-let
2b20: 20 20 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 ...).
2b30: 20 20 20 20 20 20 20 28 69 62 2d 73 61 76 65 20 (ib-save
2b40: 20 20 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 ...).
2b50: 20 20 20 20 20 20 20 28 69 62 2d 72 65 73 74 6f (ib-resto
2b60: 72 65 20 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 re ...).
2b70: 20 20 20 20 20 20 20 28 3a 64 6f 20 6f 6c 65 74 (:do olet
2b80: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2b90: 20 20 20 20 20 20 6c 62 73 20 0a 20 20 20 20 20 lbs .
2ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e n
2bb0: 65 31 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 e1? .
2bc0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
2bd0: 69 62 2d 76 61 72 20 69 62 2d 72 68 73 29 20 69 ib-var ib-rhs) i
2be0: 62 20 2e 2e 2e 29 20 69 63 20 2e 2e 2e 29 0a 20 b ...) ic ...).
2bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c00: 20 20 20 6e 65 32 3f 20 0a 20 20 20 20 20 20 20 ne2? .
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 6c 73 73 lss
2c20: 29 29 0a 20 20 20 20 20 28 3a 77 68 69 6c 65 2d )). (:while-
2c30: 32 20 63 63 20 0a 20 20 20 20 20 20 20 20 20 20 2 cc .
2c40: 20 20 20 20 20 74 65 73 74 20 0a 20 20 20 20 20 test .
2c50: 20 20 20 20 20 20 20 20 20 20 28 69 62 2d 6c 65 (ib-le
2c60: 74 20 20 20 20 20 2e 2e 2e 20 28 69 62 2d 74 6d t ... (ib-tm
2c70: 70 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 20 p #f)).
2c80: 20 20 20 20 20 20 28 69 62 2d 73 61 76 65 20 20 (ib-save
2c90: 20 20 2e 2e 2e 20 28 69 62 2d 76 61 72 20 69 62 ... (ib-var ib
2ca0: 2d 72 68 73 29 29 0a 20 20 20 20 20 20 20 20 20 -rhs)).
2cb0: 20 20 20 20 20 20 28 69 62 2d 72 65 73 74 6f 72 (ib-restor
2cc0: 65 20 2e 2e 2e 20 28 69 62 2d 76 61 72 20 69 62 e ... (ib-var ib
2cd0: 2d 74 6d 70 29 29 0a 20 20 20 20 20 20 20 20 20 -tmp)).
2ce0: 20 20 20 20 20 20 28 3a 64 6f 20 6f 6c 65 74 20 (:do olet
2cf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2d00: 20 20 20 20 20 6c 62 73 20 0a 20 20 20 20 20 20 lbs .
2d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6e 65 ne
2d20: 31 3f 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 1? .
2d30: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 69 62 (let (ib
2d40: 20 2e 2e 2e 29 20 69 63 20 2e 2e 2e 20 28 73 65 ...) ic ... (se
2d50: 74 21 20 69 62 2d 74 6d 70 20 69 62 2d 76 61 72 t! ib-tmp ib-var
2d60: 29 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 )) .
2d70: 20 20 20 20 20 20 20 20 6e 65 32 3f 20 0a 20 20 ne2? .
2d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d90: 20 20 6c 73 73 29 29 29 0a 20 20 20 20 28 28 3a lss))). ((:
2da0: 77 68 69 6c 65 2d 32 20 63 63 0a 20 20 20 20 20 while-2 cc.
2db0: 20 20 20 20 20 20 20 20 20 20 74 65 73 74 0a 20 test.
2dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
2dd0: 62 2d 6c 65 74 20 20 20 20 20 2e 2e 2e 29 0a 20 b-let ...).
2de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
2df0: 62 2d 73 61 76 65 20 20 20 20 2e 2e 2e 29 0a 20 b-save ...).
2e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
2e10: 62 2d 72 65 73 74 6f 72 65 20 2e 2e 2e 29 0a 20 b-restore ...).
2e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3a (:
2e30: 64 6f 20 28 6c 65 74 20 28 6f 62 20 2e 2e 2e 29 do (let (ob ...)
2e40: 20 6f 63 20 2e 2e 2e 29 20 6c 62 73 20 6e 65 31 oc ...) lbs ne1
2e50: 3f 20 28 6c 65 74 20 28 29 20 69 63 20 2e 2e 2e ? (let () ic ...
2e60: 29 20 6e 65 32 3f 20 6c 73 73 29 29 0a 20 20 20 ) ne2? lss)).
2e70: 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 20 (:do cc.
2e80: 20 20 20 20 28 6c 65 74 20 28 6f 62 20 2e 2e 2e (let (ob ...
2e90: 20 69 62 2d 6c 65 74 20 2e 2e 2e 29 20 6f 63 20 ib-let ...) oc
2ea0: 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 20 20 6c ...). l
2eb0: 62 73 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 bs. (le
2ec0: 74 20 28 28 6e 65 31 3f 2d 76 61 6c 75 65 20 6e t ((ne1?-value n
2ed0: 65 31 3f 29 29 0a 20 20 20 20 20 20 20 20 20 20 e1?)).
2ee0: 20 20 28 6c 65 74 20 28 69 62 2d 73 61 76 65 20 (let (ib-save
2ef0: 2e 2e 2e 29 0a 20 20 20 20 20 20 20 20 20 20 20 ...).
2f00: 20 20 20 20 20 69 63 20 2e 2e 2e 0a 20 20 20 20 ic ....
2f10: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 (and
2f20: 20 6e 65 31 3f 2d 76 61 6c 75 65 20 74 65 73 74 ne1?-value test
2f30: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c ))). (l
2f40: 65 74 20 28 69 62 2d 72 65 73 74 6f 72 65 20 2e et (ib-restore .
2f50: 2e 2e 29 29 0a 20 20 20 20 20 20 20 20 20 20 6e ..)). n
2f60: 65 32 3f 0a 20 20 20 20 20 20 20 20 20 20 6c 73 e2?. ls
2f70: 73 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 2d s))))...(define-
2f80: 73 79 6e 74 61 78 20 3a 75 6e 74 69 6c 0a 20 20 syntax :until.
2f90: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 (syntax-rules ()
2fa0: 0a 20 20 20 20 28 28 3a 75 6e 74 69 6c 20 63 63 . ((:until cc
2fb0: 20 28 67 20 61 72 67 31 20 61 72 67 20 2e 2e 2e (g arg1 arg ...
2fc0: 29 20 74 65 73 74 29 0a 20 20 20 20 20 28 67 20 ) test). (g
2fd0: 28 3a 75 6e 74 69 6c 2d 31 20 63 63 20 74 65 73 (:until-1 cc tes
2fe0: 74 29 20 61 72 67 31 20 61 72 67 20 2e 2e 2e 29 t) arg1 arg ...)
2ff0: 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 )))..(define-sy
3000: 6e 74 61 78 20 3a 75 6e 74 69 6c 2d 31 0a 20 20 ntax :until-1.
3010: 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 3a (syntax-rules (:
3020: 64 6f 29 0a 20 20 20 20 28 28 3a 75 6e 74 69 6c do). ((:until
3030: 2d 31 20 63 63 20 74 65 73 74 20 28 3a 64 6f 20 -1 cc test (:do
3040: 6f 6c 65 74 20 6c 62 73 20 6e 65 31 3f 20 69 6c olet lbs ne1? il
3050: 65 74 20 6e 65 32 3f 20 6c 73 73 29 29 0a 20 20 et ne2? lss)).
3060: 20 20 20 28 3a 64 6f 20 63 63 20 6f 6c 65 74 20 (:do cc olet
3070: 6c 62 73 20 6e 65 31 3f 20 69 6c 65 74 20 28 61 lbs ne1? ilet (a
3080: 6e 64 20 6e 65 32 3f 20 28 6e 6f 74 20 74 65 73 nd ne2? (not tes
3090: 74 29 29 20 6c 73 73 29 20 29 29 29 0a 0a 0a 3b t)) lss) )))...;
30a0: 20 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 ===========.; Th
30f0: 65 20 74 79 70 65 64 20 67 65 6e 65 72 61 74 6f e typed generato
3100: 72 73 20 3a 6c 69 73 74 20 3a 73 74 72 69 6e 67 rs :list :string
3110: 20 3a 76 65 63 74 6f 72 20 65 74 63 2e 0a 3b 20 :vector etc..;
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
3170: 69 6e 65 2d 73 79 6e 74 61 78 20 3a 6c 69 73 74 ine-syntax :list
3180: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
3190: 20 28 69 6e 64 65 78 29 0a 20 20 20 20 28 28 3a (index). ((:
31a0: 6c 69 73 74 20 63 63 20 76 61 72 20 28 69 6e 64 list cc var (ind
31b0: 65 78 20 69 29 20 61 72 67 20 2e 2e 2e 29 0a 20 ex i) arg ...).
31c0: 20 20 20 20 28 3a 70 61 72 61 6c 6c 65 6c 20 63 (:parallel c
31d0: 63 20 28 3a 6c 69 73 74 20 76 61 72 20 61 72 67 c (:list var arg
31e0: 20 2e 2e 2e 29 20 28 3a 69 6e 74 65 67 65 72 73 ...) (:integers
31f0: 20 69 29 29 20 29 0a 20 20 20 20 28 28 3a 6c 69 i)) ). ((:li
3200: 73 74 20 63 63 20 76 61 72 20 61 72 67 31 20 61 st cc var arg1 a
3210: 72 67 32 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 rg2 arg ...).
3220: 20 20 28 3a 6c 69 73 74 20 63 63 20 76 61 72 20 (:list cc var
3230: 28 61 70 70 65 6e 64 20 61 72 67 31 20 61 72 67 (append arg1 arg
3240: 32 20 61 72 67 20 2e 2e 2e 29 29 20 29 0a 20 20 2 arg ...)) ).
3250: 20 20 28 28 3a 6c 69 73 74 20 63 63 20 76 61 72 ((:list cc var
3260: 20 61 72 67 29 0a 20 20 20 20 20 28 3a 64 6f 20 arg). (:do
3270: 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 cc. (le
3280: 74 20 28 29 29 0a 20 20 20 20 20 20 20 20 20 20 t ()).
3290: 28 28 74 20 61 72 67 29 29 0a 20 20 20 20 20 20 ((t arg)).
32a0: 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (not (null?
32b0: 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c t)). (l
32c0: 65 74 20 28 28 76 61 72 20 28 63 61 72 20 74 29 et ((var (car t)
32d0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 ))). #t
32e0: 0a 20 20 20 20 20 20 20 20 20 20 28 28 63 64 72 . ((cdr
32f0: 20 74 29 29 20 29 29 29 29 0a 0a 0a 28 64 65 66 t)) ))))...(def
3300: 69 6e 65 2d 73 79 6e 74 61 78 20 3a 73 74 72 69 ine-syntax :stri
3310: 6e 67 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c ng. (syntax-rul
3320: 65 73 20 28 69 6e 64 65 78 29 0a 20 20 20 20 28 es (index). (
3330: 28 3a 73 74 72 69 6e 67 20 63 63 20 76 61 72 20 (:string cc var
3340: 28 69 6e 64 65 78 20 69 29 20 61 72 67 29 0a 20 (index i) arg).
3350: 20 20 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 (:do cc.
3360: 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 74 72 (let ((str
3370: 20 61 72 67 29 20 28 6c 65 6e 20 30 29 29 20 0a arg) (len 0)) .
3380: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
3390: 21 20 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 ! len (string-le
33a0: 6e 67 74 68 20 73 74 72 29 29 29 0a 20 20 20 20 ngth str))).
33b0: 20 20 20 20 20 20 28 28 69 20 30 29 29 0a 20 20 ((i 0)).
33c0: 20 20 20 20 20 20 20 20 28 3c 20 69 20 6c 65 6e (< i len
33d0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 ). (let
33e0: 20 28 28 76 61 72 20 28 73 74 72 69 6e 67 2d 72 ((var (string-r
33f0: 65 66 20 73 74 72 20 69 29 29 29 29 0a 20 20 20 ef str i)))).
3400: 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 #t.
3410: 20 20 20 20 28 28 2b 20 69 20 31 29 29 20 29 29 ((+ i 1)) ))
3420: 0a 20 20 20 20 28 28 3a 73 74 72 69 6e 67 20 63 . ((:string c
3430: 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 c var (index i)
3440: 61 72 67 31 20 61 72 67 32 20 61 72 67 20 2e 2e arg1 arg2 arg ..
3450: 2e 29 0a 20 20 20 20 20 28 3a 73 74 72 69 6e 67 .). (:string
3460: 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 cc var (index i
3470: 29 20 28 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 ) (string-append
3480: 20 61 72 67 31 20 61 72 67 32 20 61 72 67 20 2e arg1 arg2 arg .
3490: 2e 2e 29 29 20 29 0a 20 20 20 20 28 28 3a 73 74 ..)) ). ((:st
34a0: 72 69 6e 67 20 63 63 20 76 61 72 20 61 72 67 31 ring cc var arg1
34b0: 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 arg ...). (
34c0: 3a 73 74 72 69 6e 67 20 63 63 20 76 61 72 20 28 :string cc var (
34d0: 69 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 72 index i) arg1 ar
34e0: 67 20 2e 2e 2e 29 20 29 29 29 0a 0a 3b 20 41 6c g ...) )))..; Al
34f0: 74 65 72 6e 61 74 69 76 65 3a 20 41 6e 20 69 6d ternative: An im
3500: 70 6c 65 6d 65 6e 74 61 74 69 6f 6e 20 69 6e 20 plementation in
3510: 74 68 65 20 73 74 79 6c 65 20 6f 66 20 3a 76 65 the style of :ve
3520: 63 74 6f 72 20 63 61 6e 20 61 6c 73 6f 0a 3b 20 ctor can also.;
3530: 20 20 62 65 20 75 73 65 64 20 66 6f 72 20 3a 73 be used for :s
3540: 74 72 69 6e 67 2e 20 48 6f 77 65 76 65 72 2c 20 tring. However,
3550: 69 74 20 69 73 20 6c 65 73 73 20 69 6e 74 65 72 it is less inter
3560: 65 73 74 69 6e 67 20 61 73 20 74 68 65 0a 3b 20 esting as the.;
3570: 20 20 6f 76 65 72 68 65 61 64 20 6f 66 20 73 74 overhead of st
3580: 72 69 6e 67 2d 61 70 70 65 6e 64 20 69 73 20 6d ring-append is m
3590: 75 63 68 20 6c 65 73 73 20 74 68 61 6e 20 66 6f uch less than fo
35a0: 72 20 27 76 65 63 74 6f 72 2d 61 70 70 65 6e 64 r 'vector-append
35b0: 27 2e 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e '....(define-syn
35c0: 74 61 78 20 3a 76 65 63 74 6f 72 0a 20 20 28 73 tax :vector. (s
35d0: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 yntax-rules (ind
35e0: 65 78 29 0a 20 20 20 20 28 28 3a 76 65 63 74 6f ex). ((:vecto
35f0: 72 20 63 63 20 76 61 72 20 61 72 67 29 0a 20 20 r cc var arg).
3600: 20 20 20 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 20 29 0a 20 20 20 20 28 28 3a 76 65 63 74 6f ) ). ((:vecto
3630: 72 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 r cc var (index
3640: 69 29 20 61 72 67 29 0a 20 20 20 20 20 28 3a 64 i) arg). (:d
3650: 6f 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 o cc. (
3660: 6c 65 74 20 28 28 76 65 63 20 61 72 67 29 20 28 let ((vec arg) (
3670: 6c 65 6e 20 30 29 29 20 0a 20 20 20 20 20 20 20 len 0)) .
3680: 20 20 20 20 20 28 73 65 74 21 20 6c 65 6e 20 28 (set! len (
3690: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 vector-length ve
36a0: 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 c))). (
36b0: 28 69 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 (i 0)).
36c0: 20 28 3c 20 69 20 6c 65 6e 29 0a 20 20 20 20 20 (< i len).
36d0: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 (let ((var
36e0: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 (vector-ref vec
36f0: 69 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 i)))).
3700: 23 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 2b #t. ((+
3710: 20 69 20 31 29 29 20 29 29 0a 0a 20 20 20 20 28 i 1)) )).. (
3720: 28 3a 76 65 63 74 6f 72 20 63 63 20 76 61 72 20 (:vector cc var
3730: 28 69 6e 64 65 78 20 69 29 20 61 72 67 31 20 61 (index i) arg1 a
3740: 72 67 32 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 rg2 arg ...).
3750: 20 20 28 3a 70 61 72 61 6c 6c 65 6c 20 63 63 20 (:parallel cc
3760: 28 3a 76 65 63 74 6f 72 20 63 63 20 76 61 72 20 (:vector cc var
3770: 61 72 67 31 20 61 72 67 32 20 61 72 67 20 2e 2e arg1 arg2 arg ..
3780: 2e 29 20 28 3a 69 6e 74 65 67 65 72 73 20 69 29 .) (:integers i)
3790: 29 20 29 0a 20 20 20 20 28 28 3a 76 65 63 74 6f ) ). ((:vecto
37a0: 72 20 63 63 20 76 61 72 20 61 72 67 31 20 61 72 r cc var arg1 ar
37b0: 67 32 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 g2 arg ...).
37c0: 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 20 20 (:do cc.
37d0: 20 20 20 28 6c 65 74 20 28 28 76 65 63 20 23 66 (let ((vec #f
37e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
37f0: 20 20 28 6c 65 6e 20 30 29 0a 20 20 20 20 20 20 (len 0).
3800: 20 20 20 20 20 20 20 20 20 20 28 76 65 63 73 20 (vecs
3810: 28 65 63 2d 3a 76 65 63 74 6f 72 2d 66 69 6c 74 (ec-:vector-filt
3820: 65 72 20 28 6c 69 73 74 20 61 72 67 31 20 61 72 er (list arg1 ar
3830: 67 32 20 61 72 67 20 2e 2e 2e 29 29 29 20 29 29 g2 arg ...))) ))
3840: 0a 20 20 20 20 20 20 20 20 20 20 28 28 6b 20 30 . ((k 0
3850: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
3860: 20 28 3c 20 6b 20 6c 65 6e 29 0a 20 20 20 20 20 (< k len).
3870: 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 #t.
3880: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
3890: 75 6c 6c 3f 20 76 65 63 73 29 0a 20 20 20 20 20 ull? vecs).
38a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a #f.
38b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38c0: 20 20 28 62 65 67 69 6e 20 28 73 65 74 21 20 76 (begin (set! v
38d0: 65 63 20 28 63 61 72 20 76 65 63 73 29 29 0a 20 ec (car vecs)).
38e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
38f0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 76 65 (set! ve
3900: 63 73 20 28 63 64 72 20 76 65 63 73 29 29 0a 20 cs (cdr vecs)).
3910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3920: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 6c 65 (set! le
3930: 6e 20 28 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 n (vector-length
3940: 20 76 65 63 29 29 0a 20 20 20 20 20 20 20 20 20 vec)).
3950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3960: 28 73 65 74 21 20 6b 20 30 29 0a 20 20 20 20 20 (set! k 0).
3970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3980: 20 20 20 20 23 74 20 29 29 29 0a 20 20 20 20 20 #t ))).
3990: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 (let ((var
39a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 76 65 63 20 (vector-ref vec
39b0: 6b 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 k)))).
39c0: 23 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 2b #t. ((+
39d0: 20 6b 20 31 29 29 20 29 29 29 29 0a 0a 28 64 65 k 1)) ))))..(de
39e0: 66 69 6e 65 20 28 65 63 2d 3a 76 65 63 74 6f 72 fine (ec-:vector
39f0: 2d 66 69 6c 74 65 72 20 76 65 63 73 29 0a 20 20 -filter vecs).
3a00: 28 69 66 20 28 6e 75 6c 6c 3f 20 76 65 63 73 29 (if (null? vecs)
3a10: 0a 20 20 20 20 20 20 27 28 29 0a 20 20 20 20 20 . '().
3a20: 20 28 69 66 20 28 7a 65 72 6f 3f 20 28 76 65 63 (if (zero? (vec
3a30: 74 6f 72 2d 6c 65 6e 67 74 68 20 28 63 61 72 20 tor-length (car
3a40: 76 65 63 73 29 29 29 0a 20 20 20 20 20 20 20 20 vecs))).
3a50: 20 20 28 65 63 2d 3a 76 65 63 74 6f 72 2d 66 69 (ec-:vector-fi
3a60: 6c 74 65 72 20 28 63 64 72 20 76 65 63 73 29 29 lter (cdr vecs))
3a70: 0a 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 . (cons
3a80: 20 28 63 61 72 20 76 65 63 73 29 20 28 65 63 2d (car vecs) (ec-
3a90: 3a 76 65 63 74 6f 72 2d 66 69 6c 74 65 72 20 28 :vector-filter (
3aa0: 63 64 72 20 76 65 63 73 29 29 29 20 29 29 29 0a cdr vecs))) ))).
3ab0: 0a 3b 20 41 6c 74 65 72 6e 61 74 69 76 65 3a 20 .; Alternative:
3ac0: 41 20 73 69 6d 70 6c 65 72 20 69 6d 70 6c 65 6d A simpler implem
3ad0: 65 6e 74 61 74 69 6f 6e 20 66 6f 72 20 3a 76 65 entation for :ve
3ae0: 63 74 6f 72 20 75 73 65 73 20 76 65 63 74 6f 72 ctor uses vector
3af0: 2d 3e 6c 69 73 74 0a 3b 20 20 20 61 70 70 65 6e ->list.; appen
3b00: 64 20 61 6e 64 20 3a 6c 69 73 74 20 69 6e 20 74 d and :list in t
3b10: 68 65 20 6d 75 6c 74 69 2d 61 72 67 75 6d 65 6e he multi-argumen
3b20: 74 20 63 61 73 65 2e 20 50 6c 65 61 73 65 20 72 t case. Please r
3b30: 65 66 65 72 20 74 6f 20 74 68 65 0a 3b 20 20 20 efer to the.;
3b40: 27 64 65 73 69 67 6e 2e 73 63 6d 27 20 66 6f 72 'design.scm' for
3b50: 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 2e 0a 0a more details...
3b60: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax
3b70: 3a 69 6e 74 65 67 65 72 73 0a 20 20 28 73 79 6e :integers. (syn
3b80: 74 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 65 78 tax-rules (index
3b90: 29 0a 20 20 20 20 28 28 3a 69 6e 74 65 67 65 72 ). ((:integer
3ba0: 73 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 s cc var (index
3bb0: 69 29 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 i)). (:do cc
3bc0: 20 28 28 76 61 72 20 30 29 20 28 69 20 30 29 29 ((var 0) (i 0))
3bd0: 20 23 74 20 28 28 2b 20 76 61 72 20 31 29 20 28 #t ((+ var 1) (
3be0: 2b 20 69 20 31 29 29 29 20 29 0a 20 20 20 20 28 + i 1))) ). (
3bf0: 28 3a 69 6e 74 65 67 65 72 73 20 63 63 20 76 61 (:integers cc va
3c00: 72 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 20 r). (:do cc
3c10: 28 28 76 61 72 20 30 29 29 20 23 74 20 28 28 2b ((var 0)) #t ((+
3c20: 20 76 61 72 20 31 29 29 29 20 29 29 29 0a 0a 0a var 1))) )))...
3c30: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 3a (define-syntax :
3c40: 72 61 6e 67 65 0a 20 20 28 73 79 6e 74 61 78 2d range. (syntax-
3c50: 72 75 6c 65 73 20 28 69 6e 64 65 78 29 0a 0a 20 rules (index)..
3c60: 20 20 20 3b 20 68 61 6e 64 6c 65 20 69 6e 64 65 ; handle inde
3c70: 78 20 76 61 72 69 61 62 6c 65 20 61 6e 64 20 61 x variable and a
3c80: 64 64 20 6f 70 74 69 6f 6e 61 6c 20 61 72 67 73 dd optional args
3c90: 0a 20 20 20 20 28 28 3a 72 61 6e 67 65 20 63 63 . ((:range cc
3ca0: 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 var (index i) a
3cb0: 72 67 31 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 rg1 arg ...).
3cc0: 20 20 28 3a 70 61 72 61 6c 6c 65 6c 20 63 63 20 (:parallel cc
3cd0: 28 3a 72 61 6e 67 65 20 76 61 72 20 61 72 67 31 (:range var arg1
3ce0: 20 61 72 67 20 2e 2e 2e 29 20 28 3a 69 6e 74 65 arg ...) (:inte
3cf0: 67 65 72 73 20 69 29 29 20 29 0a 20 20 20 20 28 gers i)) ). (
3d00: 28 3a 72 61 6e 67 65 20 63 63 20 76 61 72 20 61 (:range cc var a
3d10: 72 67 31 29 0a 20 20 20 20 20 28 3a 72 61 6e 67 rg1). (:rang
3d20: 65 20 63 63 20 76 61 72 20 30 20 61 72 67 31 20 e cc var 0 arg1
3d30: 31 29 20 29 0a 20 20 20 20 28 28 3a 72 61 6e 67 1) ). ((:rang
3d40: 65 20 63 63 20 76 61 72 20 61 72 67 31 20 61 72 e cc var arg1 ar
3d50: 67 32 29 0a 20 20 20 20 20 28 3a 72 61 6e 67 65 g2). (:range
3d60: 20 63 63 20 76 61 72 20 61 72 67 31 20 61 72 67 cc var arg1 arg
3d70: 32 20 31 29 20 29 0a 0a 3b 20 73 70 65 63 69 61 2 1) )..; specia
3d80: 6c 20 63 61 73 65 73 20 28 70 61 72 74 69 61 6c l cases (partial
3d90: 6c 79 20 65 76 61 6c 75 61 74 65 64 20 62 79 20 ly evaluated by
3da0: 68 61 6e 64 20 66 72 6f 6d 20 67 65 6e 65 72 61 hand from genera
3db0: 6c 20 63 61 73 65 29 0a 0a 20 20 20 20 28 28 3a l case).. ((:
3dc0: 72 61 6e 67 65 20 63 63 20 76 61 72 20 30 20 61 range cc var 0 a
3dd0: 72 67 32 20 31 29 0a 20 20 20 20 20 28 3a 64 6f rg2 1). (:do
3de0: 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c cc. (l
3df0: 65 74 20 28 28 62 20 61 72 67 32 29 29 0a 20 20 et ((b arg2)).
3e00: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e (if (n
3e10: 6f 74 20 28 61 6e 64 20 28 69 6e 74 65 67 65 72 ot (and (integer
3e20: 3f 20 62 29 20 28 65 78 61 63 74 3f 20 62 29 29 ? b) (exact? b))
3e30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3e40: 20 20 28 65 72 72 6f 72 20 0a 20 20 20 20 20 20 (error .
3e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 61 72 "ar
3e60: 67 75 6d 65 6e 74 73 20 6f 66 20 3a 72 61 6e 67 guments of :rang
3e70: 65 20 61 72 65 20 6e 6f 74 20 65 78 61 63 74 20 e are not exact
3e80: 69 6e 74 65 67 65 72 20 22 0a 20 20 20 20 20 20 integer ".
3e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 28 75 "(u
3ea0: 73 65 20 3a 72 65 61 6c 2d 72 61 6e 67 65 3f 29 se :real-range?)
3eb0: 22 20 30 20 62 20 31 20 29 29 29 0a 20 20 20 20 " 0 b 1 ))).
3ec0: 20 20 20 20 20 20 28 28 76 61 72 20 30 29 29 0a ((var 0)).
3ed0: 20 20 20 20 20 20 20 20 20 20 28 3c 20 76 61 72 (< var
3ee0: 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c b). (l
3ef0: 65 74 20 28 29 29 0a 20 20 20 20 20 20 20 20 20 et ()).
3f00: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 #t. ((
3f10: 2b 20 76 61 72 20 31 29 29 20 29 29 0a 0a 20 20 + var 1)) ))..
3f20: 20 20 28 28 3a 72 61 6e 67 65 20 63 63 20 76 61 ((:range cc va
3f30: 72 20 30 20 61 72 67 32 20 2d 31 29 0a 20 20 20 r 0 arg2 -1).
3f40: 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 20 (:do cc.
3f50: 20 20 20 20 28 6c 65 74 20 28 28 62 20 61 72 67 (let ((b arg
3f60: 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
3f70: 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 28 69 (if (not (and (i
3f80: 6e 74 65 67 65 72 3f 20 62 29 20 28 65 78 61 63 nteger? b) (exac
3f90: 74 3f 20 62 29 29 29 0a 20 20 20 20 20 20 20 20 t? b))).
3fa0: 20 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 0a (error .
3fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3fc0: 20 20 20 22 61 72 67 75 6d 65 6e 74 73 20 6f 66 "arguments of
3fd0: 20 3a 72 61 6e 67 65 20 61 72 65 20 6e 6f 74 20 :range are not
3fe0: 65 78 61 63 74 20 69 6e 74 65 67 65 72 20 22 0a exact integer ".
3ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4000: 20 20 20 22 28 75 73 65 20 3a 72 65 61 6c 2d 72 "(use :real-r
4010: 61 6e 67 65 3f 29 22 20 30 20 62 20 31 20 29 29 ange?)" 0 b 1 ))
4020: 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 76 61 ). ((va
4030: 72 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 r 0)).
4040: 28 3e 20 76 61 72 20 62 29 0a 20 20 20 20 20 20 (> var b).
4050: 20 20 20 20 28 6c 65 74 20 28 29 29 0a 20 20 20 (let ()).
4060: 20 20 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 #t.
4070: 20 20 20 20 28 28 2d 20 76 61 72 20 31 29 29 20 ((- var 1))
4080: 29 29 0a 0a 20 20 20 20 28 28 3a 72 61 6e 67 65 )).. ((:range
4090: 20 63 63 20 76 61 72 20 61 72 67 31 20 61 72 67 cc var arg1 arg
40a0: 32 20 31 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 2 1). (:do c
40b0: 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 c. (let
40c0: 20 28 28 61 20 61 72 67 31 29 20 28 62 20 61 72 ((a arg1) (b ar
40d0: 67 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 g2)).
40e0: 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 28 (if (not (and (
40f0: 69 6e 74 65 67 65 72 3f 20 61 29 20 28 65 78 61 integer? a) (exa
4100: 63 74 3f 20 61 29 0a 20 20 20 20 20 20 20 20 20 ct? a).
4110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4120: 20 28 69 6e 74 65 67 65 72 3f 20 62 29 20 28 65 (integer? b) (e
4130: 78 61 63 74 3f 20 62 29 20 29 29 0a 20 20 20 20 xact? b) )).
4140: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 (err
4150: 6f 72 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 or .
4160: 20 20 20 20 20 20 20 22 61 72 67 75 6d 65 6e 74 "argument
4170: 73 20 6f 66 20 3a 72 61 6e 67 65 20 61 72 65 20 s of :range are
4180: 6e 6f 74 20 65 78 61 63 74 20 69 6e 74 65 67 65 not exact intege
4190: 72 20 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 r ".
41a0: 20 20 20 20 20 20 20 22 28 75 73 65 20 3a 72 65 "(use :re
41b0: 61 6c 2d 72 61 6e 67 65 3f 29 22 20 61 20 62 20 al-range?)" a b
41c0: 31 20 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 1 )) ).
41d0: 20 28 28 76 61 72 20 61 29 29 0a 20 20 20 20 20 ((var a)).
41e0: 20 20 20 20 20 28 3c 20 76 61 72 20 62 29 0a 20 (< var b).
41f0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 29 (let ()
4200: 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 ). #t.
4210: 20 20 20 20 20 20 20 20 20 28 28 2b 20 76 61 72 ((+ var
4220: 20 31 29 29 20 29 29 0a 0a 20 20 20 20 28 28 3a 1)) )).. ((:
4230: 72 61 6e 67 65 20 63 63 20 76 61 72 20 61 72 67 range cc var arg
4240: 31 20 61 72 67 32 20 2d 31 29 0a 20 20 20 20 20 1 arg2 -1).
4250: 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 20 20 20 (:do cc.
4260: 20 20 28 6c 65 74 20 28 28 61 20 61 72 67 31 29 (let ((a arg1)
4270: 20 28 62 20 61 72 67 32 29 20 28 73 20 2d 31 29 (b arg2) (s -1)
4280: 20 28 73 74 6f 70 20 30 29 29 0a 20 20 20 20 20 (stop 0)).
4290: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
42a0: 28 61 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 61 (and (integer? a
42b0: 29 20 28 65 78 61 63 74 3f 20 61 29 0a 20 20 20 ) (exact? a).
42c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
42d0: 20 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 3f (integer?
42e0: 20 62 29 20 28 65 78 61 63 74 3f 20 62 29 20 29 b) (exact? b) )
42f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4300: 20 20 28 65 72 72 6f 72 20 0a 20 20 20 20 20 20 (error .
4310: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 61 72 "ar
4320: 67 75 6d 65 6e 74 73 20 6f 66 20 3a 72 61 6e 67 guments of :rang
4330: 65 20 61 72 65 20 6e 6f 74 20 65 78 61 63 74 20 e are not exact
4340: 69 6e 74 65 67 65 72 20 22 0a 20 20 20 20 20 20 integer ".
4350: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 28 75 "(u
4360: 73 65 20 3a 72 65 61 6c 2d 72 61 6e 67 65 3f 29 se :real-range?)
4370: 22 20 61 20 62 20 2d 31 20 29 29 20 29 0a 20 20 " a b -1 )) ).
4380: 20 20 20 20 20 20 20 20 28 28 76 61 72 20 61 29 ((var a)
4390: 29 0a 20 20 20 20 20 20 20 20 20 20 28 3e 20 76 ). (> v
43a0: 61 72 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 ar b).
43b0: 28 6c 65 74 20 28 29 29 0a 20 20 20 20 20 20 20 (let ()).
43c0: 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 #t.
43d0: 28 28 2d 20 76 61 72 20 31 29 29 20 29 29 0a 0a ((- var 1)) ))..
43e0: 3b 20 74 68 65 20 67 65 6e 65 72 61 6c 20 63 61 ; the general ca
43f0: 73 65 0a 0a 20 20 20 20 28 28 3a 72 61 6e 67 65 se.. ((:range
4400: 20 63 63 20 76 61 72 20 61 72 67 31 20 61 72 67 cc var arg1 arg
4410: 32 20 61 72 67 33 29 0a 20 20 20 20 20 28 3a 64 2 arg3). (:d
4420: 6f 20 63 63 0a 20 20 20 20 20 20 20 20 20 20 28 o cc. (
4430: 6c 65 74 20 28 28 61 20 61 72 67 31 29 20 28 62 let ((a arg1) (b
4440: 20 61 72 67 32 29 20 28 73 20 61 72 67 33 29 20 arg2) (s arg3)
4450: 28 73 74 6f 70 20 30 29 29 0a 20 20 20 20 20 20 (stop 0)).
4460: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
4470: 61 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 61 29 and (integer? a)
4480: 20 28 65 78 61 63 74 3f 20 61 29 0a 20 20 20 20 (exact? a).
4490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44a0: 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 3f 20 (integer?
44b0: 62 29 20 28 65 78 61 63 74 3f 20 62 29 0a 20 20 b) (exact? b).
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44d0: 20 20 20 20 20 20 20 20 28 69 6e 74 65 67 65 72 (integer
44e0: 3f 20 73 29 20 28 65 78 61 63 74 3f 20 73 29 20 ? s) (exact? s)
44f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
4500: 20 20 20 28 65 72 72 6f 72 20 0a 20 20 20 20 20 (error .
4510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 61 "a
4520: 72 67 75 6d 65 6e 74 73 20 6f 66 20 3a 72 61 6e rguments of :ran
4530: 67 65 20 61 72 65 20 6e 6f 74 20 65 78 61 63 74 ge are not exact
4540: 20 69 6e 74 65 67 65 72 20 22 0a 20 20 20 20 20 integer ".
4550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 28 "(
4560: 75 73 65 20 3a 72 65 61 6c 2d 72 61 6e 67 65 3f use :real-range?
4570: 29 22 20 61 20 62 20 73 20 29 29 0a 20 20 20 20 )" a b s )).
4580: 20 20 20 20 20 20 20 20 28 69 66 20 28 7a 65 72 (if (zer
4590: 6f 3f 20 73 29 0a 20 20 20 20 20 20 20 20 20 20 o? s).
45a0: 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 73 74 (error "st
45b0: 65 70 20 73 69 7a 65 20 6d 75 73 74 20 6e 6f 74 ep size must not
45c0: 20 62 65 20 7a 65 72 6f 20 69 6e 20 3a 72 61 6e be zero in :ran
45d0: 67 65 22 29 20 29 0a 20 20 20 20 20 20 20 20 20 ge") ).
45e0: 20 20 20 28 73 65 74 21 20 73 74 6f 70 20 28 2b (set! stop (+
45f0: 20 61 20 28 2a 20 28 6d 61 78 20 30 20 28 63 65 a (* (max 0 (ce
4600: 69 6c 69 6e 67 20 28 2f 20 28 2d 20 62 20 61 29 iling (/ (- b a)
4610: 20 73 29 29 29 20 73 29 29 29 20 29 0a 20 20 20 s))) s))) ).
4620: 20 20 20 20 20 20 20 28 28 76 61 72 20 61 29 29 ((var a))
4630: 0a 20 20 20 20 20 20 20 20 20 20 28 6e 6f 74 20 . (not
4640: 28 3d 20 76 61 72 20 73 74 6f 70 29 29 0a 20 20 (= var stop)).
4650: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 29 29 (let ())
4660: 0a 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 20 . #t.
4670: 20 20 20 20 20 20 20 20 28 28 2b 20 76 61 72 20 ((+ var
4680: 73 29 29 20 29 29 29 29 0a 0a 3b 20 43 6f 6d 6d s)) ))))..; Comm
4690: 65 6e 74 3a 20 54 68 65 20 6d 61 63 72 6f 20 3a ent: The macro :
46a0: 72 61 6e 67 65 20 69 6e 73 65 72 74 73 20 73 6f range inserts so
46b0: 6d 65 20 63 6f 64 65 20 74 6f 20 6d 61 6b 65 20 me code to make
46c0: 73 75 72 65 20 74 68 65 20 76 61 6c 75 65 73 0a sure the values.
46d0: 3b 20 20 20 61 72 65 20 65 78 61 63 74 20 69 6e ; are exact in
46e0: 74 65 67 65 72 73 2e 20 54 68 69 73 20 6f 76 65 tegers. This ove
46f0: 72 68 65 61 64 20 68 61 73 20 70 72 6f 76 65 6e rhead has proven
4700: 20 76 65 72 79 20 68 65 6c 70 66 75 6c 20 66 6f very helpful fo
4710: 72 20 0a 3b 20 20 20 73 61 76 69 6e 67 20 75 73 r .; saving us
4720: 65 72 73 20 66 72 6f 6d 20 74 68 65 6d 73 65 6c ers from themsel
4730: 76 65 73 2e 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 ves....(define-s
4740: 79 6e 74 61 78 20 3a 72 65 61 6c 2d 72 61 6e 67 yntax :real-rang
4750: 65 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 e. (syntax-rule
4760: 73 20 28 69 6e 64 65 78 29 0a 0a 20 20 20 20 3b s (index).. ;
4770: 20 61 64 64 20 6f 70 74 69 6f 6e 61 6c 20 61 72 add optional ar
4780: 67 73 20 61 6e 64 20 69 6e 64 65 78 20 76 61 72 gs and index var
4790: 69 61 62 6c 65 0a 20 20 20 20 28 28 3a 72 65 61 iable. ((:rea
47a0: 6c 2d 72 61 6e 67 65 20 63 63 20 76 61 72 20 61 l-range cc var a
47b0: 72 67 31 29 0a 20 20 20 20 20 28 3a 72 65 61 6c rg1). (:real
47c0: 2d 72 61 6e 67 65 20 63 63 20 76 61 72 20 28 69 -range cc var (i
47d0: 6e 64 65 78 20 69 29 20 30 20 61 72 67 31 20 31 ndex i) 0 arg1 1
47e0: 29 20 29 0a 20 20 20 20 28 28 3a 72 65 61 6c 2d ) ). ((:real-
47f0: 72 61 6e 67 65 20 63 63 20 76 61 72 20 28 69 6e range cc var (in
4800: 64 65 78 20 69 29 20 61 72 67 31 29 0a 20 20 20 dex i) arg1).
4810: 20 20 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 (:real-range c
4820: 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 c var (index i)
4830: 30 20 61 72 67 31 20 31 29 20 29 0a 20 20 20 20 0 arg1 1) ).
4840: 28 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 ((:real-range cc
4850: 20 76 61 72 20 61 72 67 31 20 61 72 67 32 29 0a var arg1 arg2).
4860: 20 20 20 20 20 28 3a 72 65 61 6c 2d 72 61 6e 67 (:real-rang
4870: 65 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 e cc var (index
4880: 69 29 20 61 72 67 31 20 61 72 67 32 20 31 29 20 i) arg1 arg2 1)
4890: 29 0a 20 20 20 20 28 28 3a 72 65 61 6c 2d 72 61 ). ((:real-ra
48a0: 6e 67 65 20 63 63 20 76 61 72 20 28 69 6e 64 65 nge cc var (inde
48b0: 78 20 69 29 20 61 72 67 31 20 61 72 67 32 29 0a x i) arg1 arg2).
48c0: 20 20 20 20 20 28 3a 72 65 61 6c 2d 72 61 6e 67 (:real-rang
48d0: 65 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 e cc var (index
48e0: 69 29 20 61 72 67 31 20 61 72 67 32 20 31 29 20 i) arg1 arg2 1)
48f0: 29 0a 20 20 20 20 28 28 3a 72 65 61 6c 2d 72 61 ). ((:real-ra
4900: 6e 67 65 20 63 63 20 76 61 72 20 61 72 67 31 20 nge cc var arg1
4910: 61 72 67 32 20 61 72 67 33 29 0a 20 20 20 20 20 arg2 arg3).
4920: 28 3a 72 65 61 6c 2d 72 61 6e 67 65 20 63 63 20 (:real-range cc
4930: 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 var (index i) ar
4940: 67 31 20 61 72 67 32 20 61 72 67 33 29 20 29 0a g1 arg2 arg3) ).
4950: 0a 20 20 20 20 3b 20 74 68 65 20 66 75 6c 6c 79 . ; the fully
4960: 20 71 75 61 6c 69 66 69 65 64 20 63 61 73 65 0a qualified case.
4970: 20 20 20 20 28 28 3a 72 65 61 6c 2d 72 61 6e 67 ((:real-rang
4980: 65 20 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 e cc var (index
4990: 69 29 20 61 72 67 31 20 61 72 67 32 20 61 72 67 i) arg1 arg2 arg
49a0: 33 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 63 0a 3). (:do cc.
49b0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
49c0: 28 61 20 61 72 67 31 29 20 28 62 20 61 72 67 32 (a arg1) (b arg2
49d0: 29 20 28 73 20 61 72 67 33 29 20 28 69 73 74 6f ) (s arg3) (isto
49e0: 70 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 p 0)).
49f0: 20 20 28 69 66 20 28 6e 6f 74 20 28 61 6e 64 20 (if (not (and
4a00: 28 72 65 61 6c 3f 20 61 29 20 28 72 65 61 6c 3f (real? a) (real?
4a10: 20 62 29 20 28 72 65 61 6c 3f 20 73 29 29 29 0a b) (real? s))).
4a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a30: 28 65 72 72 6f 72 20 22 61 72 67 75 6d 65 6e 74 (error "argument
4a40: 73 20 6f 66 20 3a 72 65 61 6c 2d 72 61 6e 67 65 s of :real-range
4a50: 20 61 72 65 20 6e 6f 74 20 72 65 61 6c 22 20 61 are not real" a
4a60: 20 62 20 73 29 20 29 0a 20 20 20 20 20 20 20 20 b s) ).
4a70: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 65 78 (if (and (ex
4a80: 61 63 74 3f 20 61 29 20 28 6f 72 20 28 6e 6f 74 act? a) (or (not
4a90: 20 28 65 78 61 63 74 3f 20 62 29 29 20 28 6e 6f (exact? b)) (no
4aa0: 74 20 28 65 78 61 63 74 3f 20 73 29 29 29 29 0a t (exact? s)))).
4ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ac0: 28 73 65 74 21 20 61 20 28 65 78 61 63 74 2d 3e (set! a (exact->
4ad0: 69 6e 65 78 61 63 74 20 61 29 29 20 29 0a 20 20 inexact a)) ).
4ae0: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
4af0: 69 73 74 6f 70 20 28 2f 20 28 2d 20 62 20 61 29 istop (/ (- b a)
4b00: 20 73 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 s)) ).
4b10: 20 28 28 69 20 30 29 29 0a 20 20 20 20 20 20 20 ((i 0)).
4b20: 20 20 20 28 3c 20 69 20 69 73 74 6f 70 29 0a 20 (< i istop).
4b30: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
4b40: 76 61 72 20 28 2b 20 61 20 28 2a 20 73 20 69 29 var (+ a (* s i)
4b50: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 23 )))). #
4b60: 74 0a 20 20 20 20 20 20 20 20 20 20 28 28 2b 20 t. ((+
4b70: 69 20 31 29 29 20 29 29 29 29 0a 0a 3b 20 43 6f i 1)) ))))..; Co
4b80: 6d 6d 65 6e 74 3a 20 54 68 65 20 6d 61 63 72 6f mment: The macro
4b90: 20 3a 72 65 61 6c 2d 72 61 6e 67 65 20 61 64 61 :real-range ada
4ba0: 70 74 73 20 74 68 65 20 65 78 61 63 74 6e 65 73 pts the exactnes
4bb0: 73 20 6f 66 20 74 68 65 20 73 74 61 72 74 0a 3b s of the start.;
4bc0: 20 20 20 76 61 6c 75 65 20 69 6e 20 63 61 73 65 value in case
4bd0: 20 61 6e 79 20 6f 66 20 74 68 65 20 6f 74 68 65 any of the othe
4be0: 72 20 76 61 6c 75 65 73 20 69 73 20 69 6e 65 78 r values is inex
4bf0: 61 63 74 2e 20 54 68 69 73 20 69 73 20 61 0a 3b act. This is a.;
4c00: 20 20 20 70 72 65 63 61 75 74 69 6f 6e 20 74 6f precaution to
4c10: 20 61 76 6f 69 64 20 28 6c 69 73 74 2d 65 63 20 avoid (list-ec
4c20: 28 3a 20 78 20 30 20 33 2e 30 29 20 78 29 20 3d (: x 0 3.0) x) =
4c30: 3e 20 27 28 30 20 31 2e 30 20 32 2e 30 29 2e 0a > '(0 1.0 2.0)..
4c40: 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 2d 73 79 . .(define-sy
4c50: 6e 74 61 78 20 3a 63 68 61 72 2d 72 61 6e 67 65 ntax :char-range
4c60: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
4c70: 20 28 69 6e 64 65 78 29 0a 20 20 20 20 28 28 3a (index). ((:
4c80: 63 68 61 72 2d 72 61 6e 67 65 20 63 63 20 76 61 char-range cc va
4c90: 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 67 31 r (index i) arg1
4ca0: 20 61 72 67 32 29 0a 20 20 20 20 20 28 3a 70 61 arg2). (:pa
4cb0: 72 61 6c 6c 65 6c 20 63 63 20 28 3a 63 68 61 72 rallel cc (:char
4cc0: 2d 72 61 6e 67 65 20 76 61 72 20 61 72 67 31 20 -range var arg1
4cd0: 61 72 67 32 29 20 28 3a 69 6e 74 65 67 65 72 73 arg2) (:integers
4ce0: 20 69 29 29 20 29 0a 20 20 20 20 28 28 3a 63 68 i)) ). ((:ch
4cf0: 61 72 2d 72 61 6e 67 65 20 63 63 20 76 61 72 20 ar-range cc var
4d00: 61 72 67 31 20 61 72 67 32 29 0a 20 20 20 20 20 arg1 arg2).
4d10: 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 20 20 20 (:do cc.
4d20: 20 20 28 6c 65 74 20 28 28 69 6d 61 78 20 28 63 (let ((imax (c
4d30: 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 61 72 67 har->integer arg
4d40: 32 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 2)))).
4d50: 28 28 69 20 28 63 68 61 72 2d 3e 69 6e 74 65 67 ((i (char->integ
4d60: 65 72 20 61 72 67 31 29 29 29 0a 20 20 20 20 20 er arg1))).
4d70: 20 20 20 20 20 28 3c 3d 20 69 20 69 6d 61 78 29 (<= i imax)
4d80: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 . (let
4d90: 28 28 76 61 72 20 28 69 6e 74 65 67 65 72 2d 3e ((var (integer->
4da0: 63 68 61 72 20 69 29 29 29 29 0a 20 20 20 20 20 char i)))).
4db0: 20 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 #t.
4dc0: 20 20 28 28 2b 20 69 20 31 29 29 20 29 29 29 29 ((+ i 1)) ))))
4dd0: 0a 0a 3b 20 57 61 72 6e 69 6e 67 3a 20 54 68 65 ..; Warning: The
4de0: 72 65 20 69 73 20 6e 6f 20 52 35 52 53 2d 77 61 re is no R5RS-wa
4df0: 79 20 74 6f 20 69 6d 70 6c 65 6d 65 6e 74 20 74 y to implement t
4e00: 68 65 20 3a 63 68 61 72 2d 72 61 6e 67 65 20 67 he :char-range g
4e10: 65 6e 65 72 61 74 6f 72 20 0a 3b 20 20 20 62 65 enerator .; be
4e20: 63 61 75 73 65 20 74 68 65 20 69 6e 74 65 67 65 cause the intege
4e30: 72 73 20 6f 62 74 61 69 6e 65 64 20 62 79 20 63 rs obtained by c
4e40: 68 61 72 2d 3e 69 6e 74 65 67 65 72 20 61 72 65 har->integer are
4e50: 20 6e 6f 74 20 6e 65 63 65 73 73 61 72 69 6c 79 not necessarily
4e60: 20 0a 3b 20 20 20 63 6f 6e 73 65 63 75 74 69 76 .; consecutiv
4e70: 65 2e 20 57 65 20 73 69 6d 70 6c 79 20 61 73 73 e. We simply ass
4e80: 75 6d 65 20 74 68 69 73 20 61 6e 79 68 6f 77 20 ume this anyhow
4e90: 66 6f 72 20 69 6c 6c 75 73 74 72 61 74 69 6f 6e for illustration
4ea0: 2e 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 ....(define-synt
4eb0: 61 78 20 3a 70 6f 72 74 0a 20 20 28 73 79 6e 74 ax :port. (synt
4ec0: 61 78 2d 72 75 6c 65 73 20 28 69 6e 64 65 78 29 ax-rules (index)
4ed0: 0a 20 20 20 20 28 28 3a 70 6f 72 74 20 63 63 20 . ((:port cc
4ee0: 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 var (index i) ar
4ef0: 67 31 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 g1 arg ...).
4f00: 20 28 3a 70 61 72 61 6c 6c 65 6c 20 63 63 20 28 (:parallel cc (
4f10: 3a 70 6f 72 74 20 76 61 72 20 61 72 67 31 20 61 :port var arg1 a
4f20: 72 67 20 2e 2e 2e 29 20 28 3a 69 6e 74 65 67 65 rg ...) (:intege
4f30: 72 73 20 69 29 29 20 29 0a 20 20 20 20 28 28 3a rs i)) ). ((:
4f40: 70 6f 72 74 20 63 63 20 76 61 72 20 61 72 67 29 port cc var arg)
4f50: 0a 20 20 20 20 20 28 3a 70 6f 72 74 20 63 63 20 . (:port cc
4f60: 76 61 72 20 61 72 67 20 72 65 61 64 29 20 29 0a var arg read) ).
4f70: 20 20 20 20 28 28 3a 70 6f 72 74 20 63 63 20 76 ((:port cc v
4f80: 61 72 20 61 72 67 31 20 61 72 67 32 29 0a 20 20 ar arg1 arg2).
4f90: 20 20 20 28 3a 64 6f 20 63 63 0a 20 20 20 20 20 (:do cc.
4fa0: 20 20 20 20 20 28 6c 65 74 20 28 28 70 6f 72 74 (let ((port
4fb0: 20 61 72 67 31 29 20 28 72 65 61 64 2d 70 72 6f arg1) (read-pro
4fc0: 63 20 61 72 67 32 29 29 29 0a 20 20 20 20 20 20 c arg2))).
4fd0: 20 20 20 20 28 28 76 61 72 20 28 72 65 61 64 2d ((var (read-
4fe0: 70 72 6f 63 20 70 6f 72 74 29 29 29 0a 20 20 20 proc port))).
4ff0: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 65 6f 66 (not (eof
5000: 2d 6f 62 6a 65 63 74 3f 20 76 61 72 29 29 0a 20 -object? var)).
5010: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 29 (let ()
5020: 29 0a 20 20 20 20 20 20 20 20 20 20 23 74 0a 20 ). #t.
5030: 20 20 20 20 20 20 20 20 20 28 28 72 65 61 64 2d ((read-
5040: 70 72 6f 63 20 70 6f 72 74 29 29 20 29 29 29 29 proc port)) ))))
5050: 0a 0a 0a 3b 20 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 3d 3d 3d 3d 3d 3d 3d ================
5080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
50a0: 3b 20 54 68 65 20 74 79 70 65 64 20 67 65 6e 65 ; The typed gene
50b0: 72 61 74 6f 72 20 3a 64 69 73 70 61 74 63 68 65 rator :dispatche
50c0: 64 20 61 6e 64 20 75 74 69 6c 69 74 69 65 73 20 d and utilities
50d0: 66 6f 72 20 63 6f 6e 73 74 72 75 63 74 69 6e 67 for constructing
50e0: 20 64 69 73 70 61 74 63 68 65 72 73 0a 3b 20 3d dispatchers.; =
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
5140: 6e 65 2d 73 79 6e 74 61 78 20 3a 64 69 73 70 61 ne-syntax :dispa
5150: 74 63 68 65 64 0a 20 20 28 73 79 6e 74 61 78 2d tched. (syntax-
5160: 72 75 6c 65 73 20 28 69 6e 64 65 78 29 0a 20 20 rules (index).
5170: 20 20 28 28 3a 64 69 73 70 61 74 63 68 65 64 20 ((:dispatched
5180: 63 63 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 cc var (index i)
5190: 20 64 69 73 70 61 74 63 68 20 61 72 67 31 20 61 dispatch arg1 a
51a0: 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 70 rg ...). (:p
51b0: 61 72 61 6c 6c 65 6c 20 63 63 20 0a 20 20 20 20 arallel cc .
51c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 3a 69 6e (:in
51d0: 74 65 67 65 72 73 20 69 29 0a 20 20 20 20 20 20 tegers i).
51e0: 20 20 20 20 20 20 20 20 20 20 28 3a 64 69 73 70 (:disp
51f0: 61 74 63 68 65 64 20 76 61 72 20 64 69 73 70 61 atched var dispa
5200: 74 63 68 20 61 72 67 31 20 61 72 67 20 2e 2e 2e tch arg1 arg ...
5210: 29 20 29 29 0a 20 20 20 20 28 28 3a 64 69 73 70 ) )). ((:disp
5220: 61 74 63 68 65 64 20 63 63 20 76 61 72 20 64 69 atched cc var di
5230: 73 70 61 74 63 68 20 61 72 67 31 20 61 72 67 20 spatch arg1 arg
5240: 2e 2e 2e 29 0a 20 20 20 20 20 28 3a 64 6f 20 63 ...). (:do c
5250: 63 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 c. (let
5260: 20 28 28 64 20 64 69 73 70 61 74 63 68 29 20 0a ((d dispatch) .
5270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5280: 28 61 72 67 73 20 28 6c 69 73 74 20 61 72 67 31 (args (list arg1
5290: 20 61 72 67 20 2e 2e 2e 29 29 20 0a 20 20 20 20 arg ...)) .
52a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 20 23 (g #
52b0: 66 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 f) .
52c0: 20 20 20 20 28 65 6d 70 74 79 20 28 6c 69 73 74 (empty (list
52d0: 20 23 66 29 29 20 29 0a 20 20 20 20 20 20 20 20 #f)) ).
52e0: 20 20 20 20 28 73 65 74 21 20 67 20 28 64 20 61 (set! g (d a
52f0: 72 67 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 rgs)).
5300: 20 20 28 69 66 20 28 6e 6f 74 20 28 70 72 6f 63 (if (not (proc
5310: 65 64 75 72 65 3f 20 67 29 29 0a 20 20 20 20 20 edure? g)).
5320: 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f (erro
5330: 72 20 22 75 6e 72 65 63 6f 67 6e 69 7a 65 64 20 r "unrecognized
5340: 61 72 67 75 6d 65 6e 74 73 20 69 6e 20 64 69 73 arguments in dis
5350: 70 61 74 63 68 69 6e 67 22 20 0a 20 20 20 20 20 patching" .
5360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5370: 20 20 61 72 67 73 20 0a 20 20 20 20 20 20 20 20 args .
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5390: 64 20 27 28 29 29 20 29 29 29 0a 20 20 20 20 20 d '()) ))).
53a0: 20 20 20 20 20 28 28 76 61 72 20 28 67 20 65 6d ((var (g em
53b0: 70 74 79 29 29 29 0a 20 20 20 20 20 20 20 20 20 pty))).
53c0: 20 28 6e 6f 74 20 28 65 71 3f 20 76 61 72 20 65 (not (eq? var e
53d0: 6d 70 74 79 29 29 0a 20 20 20 20 20 20 20 20 20 mpty)).
53e0: 20 28 6c 65 74 20 28 29 29 0a 20 20 20 20 20 20 (let ()).
53f0: 20 20 20 20 23 74 0a 20 20 20 20 20 20 20 20 20 #t.
5400: 20 28 28 67 20 65 6d 70 74 79 29 29 20 29 29 29 ((g empty)) )))
5410: 29 0a 0a 3b 20 43 6f 6d 6d 65 6e 74 3a 20 54 68 )..; Comment: Th
5420: 65 20 75 6e 69 71 75 65 20 6f 62 6a 65 63 74 20 e unique object
5430: 65 6d 70 74 79 20 69 73 20 63 72 65 61 74 65 64 empty is created
5440: 20 61 73 20 61 20 6e 65 77 6c 79 20 61 6c 6c 6f as a newly allo
5450: 63 61 74 65 64 0a 3b 20 20 20 6e 6f 6e 2d 65 6d cated.; non-em
5460: 70 74 79 20 6c 69 73 74 2e 20 49 74 20 69 73 20 pty list. It is
5470: 63 6f 6d 70 61 72 65 64 20 75 73 69 6e 67 20 65 compared using e
5480: 71 3f 20 77 68 69 63 68 20 64 69 73 74 69 6e 67 q? which disting
5490: 75 69 73 68 65 73 0a 3b 20 20 20 74 68 65 20 6f uishes.; the o
54a0: 62 6a 65 63 74 20 66 72 6f 6d 20 61 6e 79 20 6f bject from any o
54b0: 74 68 65 72 20 6f 62 6a 65 63 74 2c 20 61 63 63 ther object, acc
54c0: 6f 72 64 69 6e 67 20 74 6f 20 52 35 52 53 20 36 ording to R5RS 6
54d0: 2e 31 2e 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 79 .1....(define-sy
54e0: 6e 74 61 78 20 3a 67 65 6e 65 72 61 74 6f 72 2d ntax :generator-
54f0: 70 72 6f 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 proc. (syntax-r
5500: 75 6c 65 73 20 28 3a 64 6f 20 6c 65 74 29 0a 0a ules (:do let)..
5510: 20 20 20 20 3b 20 63 61 6c 6c 20 67 20 77 69 74 ; call g wit
5520: 68 20 61 20 76 61 72 69 61 62 6c 65 2c 20 72 65 h a variable, re
5530: 65 6e 74 72 79 20 61 74 20 28 2a 2a 29 0a 20 20 entry at (**).
5540: 20 20 28 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 ((:generator-p
5550: 72 6f 63 20 28 67 20 61 72 67 20 2e 2e 2e 29 29 roc (g arg ...))
5560: 0a 20 20 20 20 20 28 67 20 28 3a 67 65 6e 65 72 . (g (:gener
5570: 61 74 6f 72 2d 70 72 6f 63 20 76 61 72 29 20 76 ator-proc var) v
5580: 61 72 20 61 72 67 20 2e 2e 2e 29 20 29 0a 0a 20 ar arg ...) )..
5590: 20 20 20 3b 20 72 65 65 6e 74 72 79 20 70 6f 69 ; reentry poi
55a0: 6e 74 20 28 2a 2a 29 20 2d 3e 20 6d 61 6b 65 20 nt (**) -> make
55b0: 74 68 65 20 63 6f 64 65 20 66 72 6f 6d 20 61 20 the code from a
55c0: 73 69 6e 67 6c 65 20 3a 64 6f 0a 20 20 20 20 28 single :do. (
55d0: 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 (:generator-proc
55e0: 0a 20 20 20 20 20 20 20 76 61 72 20 0a 20 20 20 . var .
55f0: 20 20 20 20 28 3a 64 6f 20 28 6c 65 74 20 6f 62 (:do (let ob
5600: 73 20 6f 63 20 2e 2e 2e 29 20 0a 20 20 20 20 20 s oc ...) .
5610: 20 20 20 20 20 20 20 28 28 6c 76 20 6c 69 29 20 ((lv li)
5620: 2e 2e 2e 29 20 0a 20 20 20 20 20 20 20 20 20 20 ...) .
5630: 20 20 6e 65 31 3f 20 0a 20 20 20 20 20 20 20 20 ne1? .
5640: 20 20 20 20 28 6c 65 74 20 28 28 69 20 76 29 20 (let ((i v)
5650: 2e 2e 2e 29 20 69 63 20 2e 2e 2e 29 20 0a 20 20 ...) ic ...) .
5660: 20 20 20 20 20 20 20 20 20 20 6e 65 32 3f 20 0a ne2? .
5670: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 73 20 (ls
5680: 2e 2e 2e 29 29 20 29 0a 20 20 20 20 20 28 65 63 ...)) ). (ec
5690: 2d 73 69 6d 70 6c 69 66 79 20 0a 20 20 20 20 20 -simplify .
56a0: 20 28 6c 65 74 20 6f 62 73 0a 20 20 20 20 20 20 (let obs.
56b0: 20 20 20 20 6f 63 20 2e 2e 2e 0a 20 20 20 20 20 oc ....
56c0: 20 20 20 20 20 28 6c 65 74 20 28 28 6c 76 20 6c (let ((lv l
56d0: 69 29 20 2e 2e 2e 20 28 6e 65 32 20 23 74 29 29 i) ... (ne2 #t))
56e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 65 63 . (ec
56f0: 2d 73 69 6d 70 6c 69 66 79 0a 20 20 20 20 20 20 -simplify.
5700: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 69 20 (let ((i
5710: 23 66 29 20 2e 2e 2e 29 20 3b 20 76 20 6e 6f 74 #f) ...) ; v not
5720: 20 79 65 74 20 76 61 6c 69 64 0a 20 20 20 20 20 yet valid.
5730: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
5740: 61 20 28 65 6d 70 74 79 29 0a 20 20 20 20 20 20 a (empty).
5750: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
5760: 61 6e 64 20 6e 65 31 3f 20 6e 65 32 29 0a 20 20 and ne1? ne2).
5770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5780: 20 20 20 28 65 63 2d 73 69 6d 70 6c 69 66 79 0a (ec-simplify.
5790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57a0: 20 20 20 20 20 20 28 62 65 67 69 6e 20 0a 20 20 (begin .
57b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
57c0: 20 20 20 20 20 20 28 73 65 74 21 20 69 20 76 29 (set! i v)
57d0: 20 2e 2e 2e 0a 20 20 20 20 20 20 20 20 20 20 20 ....
57e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 69 63 20 ic
57f0: 2e 2e 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 ....
5800: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
5810: 20 28 28 76 61 6c 75 65 20 76 61 72 29 29 0a 20 ((value var)).
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 28 65 63 2d 73 69 6d (ec-sim
5840: 70 6c 69 66 79 0a 20 20 20 20 20 20 20 20 20 20 plify.
5850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5860: 20 28 69 66 20 6e 65 32 3f 0a 20 20 20 20 20 20 (if ne2?.
5870: 20 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 28 65 63 2d 73 69 6d (ec-sim
5890: 70 6c 69 66 79 20 0a 20 20 20 20 20 20 20 20 20 plify .
58a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58b0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 73 (begin (s
58c0: 65 74 21 20 6c 76 20 6c 73 29 20 2e 2e 2e 29 20 et! lv ls) ...)
58d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
58e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58f0: 20 28 73 65 74 21 20 6e 65 32 20 23 66 29 20 29 (set! ne2 #f) )
5900: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5910: 20 20 20 20 20 20 20 20 20 20 20 20 76 61 6c 75 valu
5920: 65 20 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 e ))).
5930: 20 20 20 20 20 20 20 20 20 20 20 65 6d 70 74 79 empty
5940: 20 29 29 29 29 29 29 29 29 0a 0a 20 20 20 20 3b )))))))).. ;
5950: 20 73 69 6c 65 6e 63 65 20 77 61 72 6e 69 6e 67 silence warning
5960: 73 20 6f 66 20 73 6f 6d 65 20 6d 61 63 72 6f 20 s of some macro
5970: 65 78 70 61 6e 64 65 72 73 0a 20 20 20 20 28 28 expanders. ((
5980: 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 :generator-proc
5990: 76 61 72 29 0a 20 20 20 20 20 28 65 72 72 6f 72 var). (error
59a0: 20 22 69 6c 6c 65 67 61 6c 20 6d 61 63 72 6f 20 "illegal macro
59b0: 63 61 6c 6c 22 29 20 29 29 29 0a 0a 0a 28 64 65 call") )))...(de
59c0: 66 69 6e 65 20 28 64 69 73 70 61 74 63 68 2d 75 fine (dispatch-u
59d0: 6e 69 6f 6e 20 64 31 20 64 32 29 0a 20 20 28 6c nion d1 d2). (l
59e0: 61 6d 62 64 61 20 28 61 72 67 73 29 0a 20 20 20 ambda (args).
59f0: 20 28 6c 65 74 20 28 28 67 31 20 28 64 31 20 61 (let ((g1 (d1 a
5a00: 72 67 73 29 29 20 28 67 32 20 28 64 32 20 61 72 rgs)) (g2 (d2 ar
5a10: 67 73 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 gs))). (if
5a20: 67 31 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 g1. (if
5a30: 20 67 32 20 0a 20 20 20 20 20 20 20 20 20 20 20 g2 .
5a40: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 61 72 (if (null? ar
5a50: 67 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 gs).
5a60: 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 69 (append (i
5a70: 66 20 28 6c 69 73 74 3f 20 67 31 29 20 67 31 20 f (list? g1) g1
5a80: 28 6c 69 73 74 20 67 31 29 29 20 0a 20 20 20 20 (list g1)) .
5a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5aa0: 20 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f (if (list?
5ab0: 20 67 32 29 20 67 32 20 28 6c 69 73 74 20 67 32 g2) g2 (list g2
5ac0: 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 )) ).
5ad0: 20 20 20 20 20 20 20 28 65 72 72 6f 72 20 22 64 (error "d
5ae0: 69 73 70 61 74 63 68 69 6e 67 20 63 6f 6e 66 6c ispatching confl
5af0: 69 63 74 22 20 61 72 67 73 20 28 64 31 20 27 28 ict" args (d1 '(
5b00: 29 29 20 28 64 32 20 27 28 29 29 29 20 29 0a 20 )) (d2 '())) ).
5b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 67 31 20 g1
5b20: 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 ). (if
5b30: 67 32 20 67 32 20 23 66 29 20 29 29 29 29 0a 0a g2 g2 #f) ))))..
5b40: 0a 3b 20 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 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 =============.;
5b90: 54 68 65 20 64 69 73 70 61 74 63 68 69 6e 67 20 The dispatching
5ba0: 67 65 6e 65 72 61 74 6f 72 20 3a 0a 3b 20 3d 3d generator :.; ==
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bf0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
5c00: 65 20 28 6d 61 6b 65 2d 69 6e 69 74 69 61 6c 2d e (make-initial-
5c10: 3a 2d 64 69 73 70 61 74 63 68 29 0a 20 20 28 6c :-dispatch). (l
5c20: 61 6d 62 64 61 20 28 61 72 67 73 29 0a 20 20 20 ambda (args).
5c30: 20 28 63 61 73 65 20 28 6c 65 6e 67 74 68 20 61 (case (length a
5c40: 72 67 73 29 0a 20 20 20 20 20 20 28 28 30 29 20 rgs). ((0)
5c50: 27 53 52 46 49 34 32 29 0a 20 20 20 20 20 20 28 'SRFI42). (
5c60: 28 31 29 20 28 6c 65 74 20 28 28 61 31 20 28 63 (1) (let ((a1 (c
5c70: 61 72 20 61 72 67 73 29 29 29 0a 20 20 20 20 20 ar args))).
5c80: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
5c90: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6c 69 ((li
5ca0: 73 74 3f 20 61 31 29 0a 20 20 20 20 20 20 20 20 st? a1).
5cb0: 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 (:generat
5cc0: 6f 72 2d 70 72 6f 63 20 28 3a 6c 69 73 74 20 61 or-proc (:list a
5cd0: 31 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 1)) ).
5ce0: 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 61 31 ((string? a1
5cf0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5d00: 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f (:generator-pro
5d10: 63 20 28 3a 73 74 72 69 6e 67 20 61 31 29 29 20 c (:string a1))
5d20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5d30: 28 28 76 65 63 74 6f 72 3f 20 61 31 29 0a 20 20 ((vector? a1).
5d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 (:g
5d50: 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a enerator-proc (:
5d60: 76 65 63 74 6f 72 20 61 31 29 29 20 29 0a 20 20 vector a1)) ).
5d70: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e ((an
5d80: 64 20 28 69 6e 74 65 67 65 72 3f 20 61 31 29 20 d (integer? a1)
5d90: 28 65 78 61 63 74 3f 20 61 31 29 29 0a 20 20 20 (exact? a1)).
5da0: 20 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 65 (:ge
5db0: 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a 72 nerator-proc (:r
5dc0: 61 6e 67 65 20 61 31 29 29 20 29 0a 20 20 20 20 ange a1)) ).
5dd0: 20 20 20 20 20 20 20 20 20 20 28 28 72 65 61 6c ((real
5de0: 3f 20 61 31 29 0a 20 20 20 20 20 20 20 20 20 20 ? a1).
5df0: 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 (:generator
5e00: 2d 70 72 6f 63 20 28 3a 72 65 61 6c 2d 72 61 6e -proc (:real-ran
5e10: 67 65 20 61 31 29 29 20 29 0a 20 20 20 20 20 20 ge a1)) ).
5e20: 20 20 20 20 20 20 20 20 28 28 69 6e 70 75 74 2d ((input-
5e30: 70 6f 72 74 3f 20 61 31 29 0a 20 20 20 20 20 20 port? a1).
5e40: 20 20 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 (:gener
5e50: 61 74 6f 72 2d 70 72 6f 63 20 28 3a 70 6f 72 74 ator-proc (:port
5e60: 20 61 31 29 29 20 29 0a 20 20 20 20 20 20 20 20 a1)) ).
5e70: 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 (else.
5e80: 20 20 20 20 20 20 20 20 20 20 20 23 66 20 29 29 #f ))
5e90: 29 29 0a 20 20 20 20 20 20 28 28 32 29 20 28 6c )). ((2) (l
5ea0: 65 74 20 28 28 61 31 20 28 63 61 72 20 61 72 67 et ((a1 (car arg
5eb0: 73 29 29 20 28 61 32 20 28 63 61 64 72 20 61 72 s)) (a2 (cadr ar
5ec0: 67 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 gs))).
5ed0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 (cond.
5ee0: 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 ((and (li
5ef0: 73 74 3f 20 61 31 29 20 28 6c 69 73 74 3f 20 61 st? a1) (list? a
5f00: 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
5f10: 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 (:generator-p
5f20: 72 6f 63 20 28 3a 6c 69 73 74 20 61 31 20 61 32 roc (:list a1 a2
5f30: 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 )) ).
5f40: 20 20 20 28 28 61 6e 64 20 28 73 74 72 69 6e 67 ((and (string
5f50: 3f 20 61 31 29 20 28 73 74 72 69 6e 67 3f 20 61 ? a1) (string? a
5f60: 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 2)).
5f70: 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 (:generator-p
5f80: 72 6f 63 20 28 3a 73 74 72 69 6e 67 20 61 31 20 roc (:string a1
5f90: 61 32 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 a2)) ).
5fa0: 20 20 20 20 20 28 28 61 6e 64 20 28 76 65 63 74 ((and (vect
5fb0: 6f 72 3f 20 61 31 29 20 28 76 65 63 74 6f 72 3f or? a1) (vector?
5fc0: 20 61 32 29 29 0a 20 20 20 20 20 20 20 20 20 20 a2)).
5fd0: 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 (:generator
5fe0: 2d 70 72 6f 63 20 28 3a 76 65 63 74 6f 72 20 61 -proc (:vector a
5ff0: 31 20 61 32 29 29 20 29 0a 20 20 20 20 20 20 20 1 a2)) ).
6000: 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 69 6e ((and (in
6010: 74 65 67 65 72 3f 20 61 31 29 20 28 65 78 61 63 teger? a1) (exac
6020: 74 3f 20 61 31 29 20 28 69 6e 74 65 67 65 72 3f t? a1) (integer?
6030: 20 61 32 29 20 28 65 78 61 63 74 3f 20 61 32 29 a2) (exact? a2)
6040: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6050: 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f (:generator-pro
6060: 63 20 28 3a 72 61 6e 67 65 20 61 31 20 61 32 29 c (:range a1 a2)
6070: 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ) ).
6080: 20 20 28 28 61 6e 64 20 28 72 65 61 6c 3f 20 61 ((and (real? a
6090: 31 29 20 28 72 65 61 6c 3f 20 61 32 29 29 0a 20 1) (real? a2)).
60a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3a (:
60b0: 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 generator-proc (
60c0: 3a 72 65 61 6c 2d 72 61 6e 67 65 20 61 31 20 61 :real-range a1 a
60d0: 32 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 2)) ).
60e0: 20 20 20 20 28 28 61 6e 64 20 28 63 68 61 72 3f ((and (char?
60f0: 20 61 31 29 20 28 63 68 61 72 3f 20 61 32 29 29 a1) (char? a2))
6100: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6110: 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 (:generator-proc
6120: 20 28 3a 63 68 61 72 2d 72 61 6e 67 65 20 61 31 (:char-range a1
6130: 20 61 32 29 29 20 29 0a 20 20 20 20 20 20 20 20 a2)) ).
6140: 20 20 20 20 20 20 28 28 61 6e 64 20 28 69 6e 70 ((and (inp
6150: 75 74 2d 70 6f 72 74 3f 20 61 31 29 20 28 70 72 ut-port? a1) (pr
6160: 6f 63 65 64 75 72 65 3f 20 61 32 29 29 0a 20 20 ocedure? a2)).
6170: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 (:g
6180: 65 6e 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a enerator-proc (:
6190: 70 6f 72 74 20 61 31 20 61 32 29 29 20 29 0a 20 port a1 a2)) ).
61a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
61b0: 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 se.
61c0: 20 20 23 66 20 29 29 29 29 0a 20 20 20 20 20 20 #f )))).
61d0: 28 28 33 29 20 28 6c 65 74 20 28 28 61 31 20 28 ((3) (let ((a1 (
61e0: 63 61 72 20 61 72 67 73 29 29 20 28 61 32 20 28 car args)) (a2 (
61f0: 63 61 64 72 20 61 72 67 73 29 29 20 28 61 33 20 cadr args)) (a3
6200: 28 63 61 64 64 72 20 61 72 67 73 29 29 29 0a 20 (caddr args))).
6210: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
6220: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
6230: 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 61 31 29 ((and (list? a1)
6240: 20 28 6c 69 73 74 3f 20 61 32 29 20 28 6c 69 73 (list? a2) (lis
6250: 74 3f 20 61 33 29 29 0a 20 20 20 20 20 20 20 20 t? a3)).
6260: 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 (:generat
6270: 6f 72 2d 70 72 6f 63 20 28 3a 6c 69 73 74 20 61 or-proc (:list a
6280: 31 20 61 32 20 61 33 29 29 20 29 0a 20 20 20 20 1 a2 a3)) ).
6290: 20 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 ((and
62a0: 28 73 74 72 69 6e 67 3f 20 61 31 29 20 28 73 74 (string? a1) (st
62b0: 72 69 6e 67 3f 20 61 32 29 20 28 73 74 72 69 6e ring? a2) (strin
62c0: 67 3f 20 61 33 29 29 0a 20 20 20 20 20 20 20 20 g? a3)).
62d0: 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 (:generat
62e0: 6f 72 2d 70 72 6f 63 20 28 3a 73 74 72 69 6e 67 or-proc (:string
62f0: 20 61 31 20 61 32 20 61 33 29 29 20 29 0a 20 20 a1 a2 a3)) ).
6300: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e ((an
6310: 64 20 28 76 65 63 74 6f 72 3f 20 61 31 29 20 28 d (vector? a1) (
6320: 76 65 63 74 6f 72 3f 20 61 32 29 20 28 76 65 63 vector? a2) (vec
6330: 74 6f 72 3f 20 61 33 29 29 0a 20 20 20 20 20 20 tor? a3)).
6340: 20 20 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 (:gener
6350: 61 74 6f 72 2d 70 72 6f 63 20 28 3a 76 65 63 74 ator-proc (:vect
6360: 6f 72 20 61 31 20 61 32 20 61 33 29 29 20 29 0a or a1 a2 a3)) ).
6370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
6380: 61 6e 64 20 28 69 6e 74 65 67 65 72 3f 20 61 31 and (integer? a1
6390: 29 20 28 65 78 61 63 74 3f 20 61 31 29 20 0a 20 ) (exact? a1) .
63a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63b0: 20 20 20 28 69 6e 74 65 67 65 72 3f 20 61 32 29 (integer? a2)
63c0: 20 28 65 78 61 63 74 3f 20 61 32 29 0a 20 20 20 (exact? a2).
63d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63e0: 20 28 69 6e 74 65 67 65 72 3f 20 61 33 29 20 28 (integer? a3) (
63f0: 65 78 61 63 74 3f 20 61 33 29 29 0a 20 20 20 20 exact? a3)).
6400: 20 20 20 20 20 20 20 20 20 20 20 28 3a 67 65 6e (:gen
6410: 65 72 61 74 6f 72 2d 70 72 6f 63 20 28 3a 72 61 erator-proc (:ra
6420: 6e 67 65 20 61 31 20 61 32 20 61 33 29 29 20 29 nge a1 a2 a3)) )
6430: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
6440: 28 61 6e 64 20 28 72 65 61 6c 3f 20 61 31 29 20 (and (real? a1)
6450: 28 72 65 61 6c 3f 20 61 32 29 20 28 72 65 61 6c (real? a2) (real
6460: 3f 20 61 33 29 29 0a 20 20 20 20 20 20 20 20 20 ? a3)).
6470: 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 6f (:generato
6480: 72 2d 70 72 6f 63 20 28 3a 72 65 61 6c 2d 72 61 r-proc (:real-ra
6490: 6e 67 65 20 61 31 20 61 32 20 61 33 29 29 20 29 nge a1 a2 a3)) )
64a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
64b0: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
64c0: 20 20 20 20 23 66 20 29 29 29 29 0a 20 20 20 20 #f )))).
64d0: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 28 (else. (
64e0: 6c 65 74 72 65 63 20 28 28 65 76 65 72 79 3f 20 letrec ((every?
64f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6500: 20 20 28 6c 61 6d 62 64 61 20 28 70 72 65 64 20 (lambda (pred
6510: 61 72 67 73 29 0a 20 20 20 20 20 20 20 20 20 20 args).
6520: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 (if (nu
6530: 6c 6c 3f 20 61 72 67 73 29 0a 20 20 20 20 20 20 ll? args).
6540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6550: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t.
6560: 20 20 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 (and
6570: 28 70 72 65 64 20 28 63 61 72 20 61 72 67 73 29 (pred (car args)
6580: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
65a0: 76 65 72 79 3f 20 70 72 65 64 20 28 63 64 72 20 very? pred (cdr
65b0: 61 72 67 73 29 29 20 29 29 29 29 29 0a 20 20 20 args)) ))))).
65c0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond.
65d0: 20 20 20 20 20 20 28 28 65 76 65 72 79 3f 20 6c ((every? l
65e0: 69 73 74 3f 20 61 72 67 73 29 0a 20 20 20 20 20 ist? args).
65f0: 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 6f (:generato
6600: 72 2d 70 72 6f 63 20 28 3a 6c 69 73 74 20 28 61 r-proc (:list (a
6610: 70 70 6c 79 20 61 70 70 65 6e 64 20 61 72 67 73 pply append args
6620: 29 29 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 ))) ).
6630: 28 28 65 76 65 72 79 3f 20 73 74 72 69 6e 67 3f ((every? string?
6640: 20 61 72 67 73 29 0a 20 20 20 20 20 20 20 20 20 args).
6650: 20 20 28 3a 67 65 6e 65 72 61 74 6f 72 2d 70 72 (:generator-pr
6660: 6f 63 20 28 3a 73 74 72 69 6e 67 20 28 61 70 70 oc (:string (app
6670: 6c 79 20 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 ly string-append
6680: 20 61 72 67 73 29 29 29 20 29 0a 20 20 20 20 20 args))) ).
6690: 20 20 20 20 20 28 28 65 76 65 72 79 3f 20 76 65 ((every? ve
66a0: 63 74 6f 72 3f 20 61 72 67 73 29 0a 20 20 20 20 ctor? args).
66b0: 20 20 20 20 20 20 20 28 3a 67 65 6e 65 72 61 74 (:generat
66c0: 6f 72 2d 70 72 6f 63 20 28 3a 6c 69 73 74 20 28 or-proc (:list (
66d0: 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6d 61 apply append (ma
66e0: 70 20 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 61 p vector->list a
66f0: 72 67 73 29 29 29 29 20 29 0a 20 20 20 20 20 20 rgs)))) ).
6700: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
6710: 20 20 20 20 20 23 66 20 29 29 29 29 29 29 29 0a #f ))))))).
6720: 0a 28 64 65 66 69 6e 65 20 3a 2d 64 69 73 70 61 .(define :-dispa
6730: 74 63 68 20 0a 20 20 28 6d 61 6b 65 2d 70 61 72 tch . (make-par
6740: 61 6d 65 74 65 72 20 28 6d 61 6b 65 2d 69 6e 69 ameter (make-ini
6750: 74 69 61 6c 2d 3a 2d 64 69 73 70 61 74 63 68 29 tial-:-dispatch)
6760: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6770: 20 20 20 28 6c 61 6d 62 64 61 20 28 78 29 20 28 (lambda (x) (
6780: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 78 if (procedure? x
6790: 29 20 78 20 28 65 72 72 6f 72 20 22 6e 6f 74 20 ) x (error "not
67a0: 61 20 70 72 6f 63 65 64 75 72 65 22 20 78 29 29 a procedure" x))
67b0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 3a 2d )))..(define (:-
67c0: 64 69 73 70 61 74 63 68 2d 72 65 66 29 0a 20 20 dispatch-ref).
67d0: 28 3a 2d 64 69 73 70 61 74 63 68 29 29 0a 0a 28 (:-dispatch))..(
67e0: 64 65 66 69 6e 65 20 28 3a 2d 64 69 73 70 61 74 define (:-dispat
67f0: 63 68 2d 73 65 74 21 20 64 69 73 70 61 74 63 68 ch-set! dispatch
6800: 29 0a 20 20 28 3a 2d 64 69 73 70 61 74 63 68 20 ). (:-dispatch
6810: 64 69 73 70 61 74 63 68 29 29 0a 0a 28 64 65 66 dispatch))..(def
6820: 69 6e 65 2d 73 79 6e 74 61 78 20 3a 0a 20 20 28 ine-syntax :. (
6830: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 69 6e syntax-rules (in
6840: 64 65 78 29 0a 20 20 20 20 28 28 3a 20 63 63 20 dex). ((: cc
6850: 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 61 72 var (index i) ar
6860: 67 31 20 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 g1 arg ...).
6870: 20 28 3a 64 69 73 70 61 74 63 68 65 64 20 63 63 (:dispatched cc
6880: 20 76 61 72 20 28 69 6e 64 65 78 20 69 29 20 28 var (index i) (
6890: 3a 2d 64 69 73 70 61 74 63 68 29 20 61 72 67 31 :-dispatch) arg1
68a0: 20 61 72 67 20 2e 2e 2e 29 20 29 0a 20 20 20 20 arg ...) ).
68b0: 28 28 3a 20 63 63 20 76 61 72 20 61 72 67 31 20 ((: cc var arg1
68c0: 61 72 67 20 2e 2e 2e 29 0a 20 20 20 20 20 28 3a arg ...). (:
68d0: 64 69 73 70 61 74 63 68 65 64 20 63 63 20 76 61 dispatched cc va
68e0: 72 20 28 3a 2d 64 69 73 70 61 74 63 68 29 20 61 r (:-dispatch) a
68f0: 72 67 31 20 61 72 67 20 2e 2e 2e 29 20 29 29 29 rg1 arg ...) )))
6900: 0a 0a 0a 3b 20 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 3d 3d 3d 3d 3d 3d 3d ================
6930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
6950: 3b 20 54 68 65 20 75 74 69 6c 69 74 79 20 63 6f ; The utility co
6960: 6d 70 72 65 68 65 6e 73 69 6f 6e 73 20 66 6f 6c mprehensions fol
6970: 64 2d 65 63 2c 20 66 6f 6c 64 33 2d 65 63 0a 3b d-ec, fold3-ec.;
6980: 20 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
69c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
69d0: 66 69 6e 65 2d 73 79 6e 74 61 78 20 66 6f 6c 64 fine-syntax fold
69e0: 33 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 3-ec. (syntax-r
69f0: 75 6c 65 73 20 28 6e 65 73 74 65 64 29 0a 20 20 ules (nested).
6a00: 20 20 28 28 66 6f 6c 64 33 2d 65 63 20 78 30 20 ((fold3-ec x0
6a10: 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 29 20 (nested q1 ...)
6a20: 71 20 65 74 63 31 20 65 74 63 32 20 65 74 63 33 q etc1 etc2 etc3
6a30: 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 etc ...). (
6a40: 66 6f 6c 64 33 2d 65 63 20 78 30 20 28 6e 65 73 fold3-ec x0 (nes
6a50: 74 65 64 20 71 31 20 2e 2e 2e 20 71 29 20 65 74 ted q1 ... q) et
6a60: 63 31 20 65 74 63 32 20 65 74 63 33 20 65 74 63 c1 etc2 etc3 etc
6a70: 20 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 66 6f ...) ). ((fo
6a80: 6c 64 33 2d 65 63 20 78 30 20 71 31 20 71 32 20 ld3-ec x0 q1 q2
6a90: 65 74 63 31 20 65 74 63 32 20 65 74 63 33 20 65 etc1 etc2 etc3 e
6aa0: 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 66 6f tc ...). (fo
6ab0: 6c 64 33 2d 65 63 20 78 30 20 28 6e 65 73 74 65 ld3-ec x0 (neste
6ac0: 64 20 71 31 20 71 32 29 20 65 74 63 31 20 65 74 d q1 q2) etc1 et
6ad0: 63 32 20 65 74 63 33 20 65 74 63 20 2e 2e 2e 29 c2 etc3 etc ...)
6ae0: 20 29 0a 20 20 20 20 28 28 66 6f 6c 64 33 2d 65 ). ((fold3-e
6af0: 63 20 78 30 20 65 78 70 72 65 73 73 69 6f 6e 20 c x0 expression
6b00: 66 31 20 66 32 29 0a 20 20 20 20 20 28 66 6f 6c f1 f2). (fol
6b10: 64 33 2d 65 63 20 78 30 20 28 6e 65 73 74 65 64 d3-ec x0 (nested
6b20: 29 20 65 78 70 72 65 73 73 69 6f 6e 20 66 31 20 ) expression f1
6b30: 66 32 29 20 29 0a 0a 20 20 20 20 28 28 66 6f 6c f2) ).. ((fol
6b40: 64 33 2d 65 63 20 78 30 20 71 75 61 6c 69 66 69 d3-ec x0 qualifi
6b50: 65 72 20 65 78 70 72 65 73 73 69 6f 6e 20 66 31 er expression f1
6b60: 20 66 32 29 0a 20 20 20 20 20 28 6c 65 74 20 28 f2). (let (
6b70: 28 72 65 73 75 6c 74 20 23 66 29 20 28 65 6d 70 (result #f) (emp
6b80: 74 79 20 23 74 29 29 0a 20 20 20 20 20 20 20 28 ty #t)). (
6b90: 64 6f 2d 65 63 20 71 75 61 6c 69 66 69 65 72 0a do-ec qualifier.
6ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
6bb0: 65 74 20 28 28 76 61 6c 75 65 20 65 78 70 72 65 et ((value expre
6bc0: 73 73 69 6f 6e 29 29 20 3b 20 64 6f 6e 27 74 20 ssion)) ; don't
6bd0: 64 75 70 6c 69 63 61 74 65 0a 20 20 20 20 20 20 duplicate.
6be0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 65 6d (if em
6bf0: 70 74 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 pty.
6c00: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 (begin (
6c10: 73 65 74 21 20 72 65 73 75 6c 74 20 28 66 31 20 set! result (f1
6c20: 76 61 6c 75 65 29 29 0a 20 20 20 20 20 20 20 20 value)).
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 65 6d 70 74 79 20 23 (set! empty #
6c50: 66 29 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 f) ).
6c60: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 72 (set! r
6c70: 65 73 75 6c 74 20 28 66 32 20 76 61 6c 75 65 20 esult (f2 value
6c80: 72 65 73 75 6c 74 29 29 20 29 29 29 0a 20 20 20 result)) ))).
6c90: 20 20 20 20 28 69 66 20 65 6d 70 74 79 20 78 30 (if empty x0
6ca0: 20 72 65 73 75 6c 74 29 20 29 29 29 29 0a 0a 0a result) ))))...
6cb0: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 66 (define-syntax f
6cc0: 6f 6c 64 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 old-ec. (syntax
6cd0: 2d 72 75 6c 65 73 20 28 6e 65 73 74 65 64 29 0a -rules (nested).
6ce0: 20 20 20 20 28 28 66 6f 6c 64 2d 65 63 20 78 30 ((fold-ec x0
6cf0: 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 29 (nested q1 ...)
6d00: 20 71 20 65 74 63 31 20 65 74 63 32 20 65 74 63 q etc1 etc2 etc
6d10: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 66 6f 6c 64 ...). (fold
6d20: 2d 65 63 20 78 30 20 28 6e 65 73 74 65 64 20 71 -ec x0 (nested q
6d30: 31 20 2e 2e 2e 20 71 29 20 65 74 63 31 20 65 74 1 ... q) etc1 et
6d40: 63 32 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 c2 etc ...) ).
6d50: 20 20 28 28 66 6f 6c 64 2d 65 63 20 78 30 20 71 ((fold-ec x0 q
6d60: 31 20 71 32 20 65 74 63 31 20 65 74 63 32 20 65 1 q2 etc1 etc2 e
6d70: 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 66 6f tc ...). (fo
6d80: 6c 64 2d 65 63 20 78 30 20 28 6e 65 73 74 65 64 ld-ec x0 (nested
6d90: 20 71 31 20 71 32 29 20 65 74 63 31 20 65 74 63 q1 q2) etc1 etc
6da0: 32 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 20 2 etc ...) ).
6db0: 20 28 28 66 6f 6c 64 2d 65 63 20 78 30 20 65 78 ((fold-ec x0 ex
6dc0: 70 72 65 73 73 69 6f 6e 20 66 32 29 0a 20 20 20 pression f2).
6dd0: 20 20 28 66 6f 6c 64 2d 65 63 20 78 30 20 28 6e (fold-ec x0 (n
6de0: 65 73 74 65 64 29 20 65 78 70 72 65 73 73 69 6f ested) expressio
6df0: 6e 20 66 32 29 20 29 0a 0a 20 20 20 20 28 28 66 n f2) ).. ((f
6e00: 6f 6c 64 2d 65 63 20 78 30 20 71 75 61 6c 69 66 old-ec x0 qualif
6e10: 69 65 72 20 65 78 70 72 65 73 73 69 6f 6e 20 66 ier expression f
6e20: 32 29 0a 20 20 20 20 20 28 6c 65 74 20 28 28 72 2). (let ((r
6e30: 65 73 75 6c 74 20 78 30 29 29 0a 20 20 20 20 20 esult x0)).
6e40: 20 20 28 64 6f 2d 65 63 20 71 75 61 6c 69 66 69 (do-ec qualifi
6e50: 65 72 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 er (set! result
6e60: 28 66 32 20 65 78 70 72 65 73 73 69 6f 6e 20 72 (f2 expression r
6e70: 65 73 75 6c 74 29 29 29 0a 20 20 20 20 20 20 20 esult))).
6e80: 72 65 73 75 6c 74 20 29 29 29 29 0a 0a 0a 3b 20 result ))))...;
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 ==========.; The
6ee0: 20 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 73 20 comprehensions
6ef0: 6c 69 73 74 2d 65 63 20 73 74 72 69 6e 67 2d 65 list-ec string-e
6f00: 63 20 76 65 63 74 6f 72 2d 65 63 20 65 74 63 2e c vector-ec etc.
6f10: 0a 3b 20 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 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
6f60: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 6c 69 define-syntax li
6f70: 73 74 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d st-ec. (syntax-
6f80: 72 75 6c 65 73 20 28 29 0a 20 20 20 20 28 28 6c rules (). ((l
6f90: 69 73 74 2d 65 63 20 65 74 63 31 20 65 74 63 20 ist-ec etc1 etc
6fa0: 2e 2e 2e 29 0a 20 20 20 20 20 28 72 65 76 65 72 ...). (rever
6fb0: 73 65 20 28 66 6f 6c 64 2d 65 63 20 27 28 29 20 se (fold-ec '()
6fc0: 65 74 63 31 20 65 74 63 20 2e 2e 2e 20 63 6f 6e etc1 etc ... con
6fd0: 73 29 29 20 29 29 29 0a 0a 3b 20 41 6c 74 65 72 s)) )))..; Alter
6fe0: 6e 61 74 69 76 65 3a 20 52 65 76 65 72 73 65 20 native: Reverse
6ff0: 63 61 6e 20 73 61 66 65 6c 79 20 62 65 20 72 65 can safely be re
7000: 70 6c 61 63 65 64 20 62 79 20 72 65 76 65 72 73 placed by revers
7010: 65 21 20 69 66 20 79 6f 75 20 68 61 76 65 20 69 e! if you have i
7020: 74 2e 0a 3b 0a 3b 20 41 6c 74 65 72 6e 61 74 69 t..;.; Alternati
7030: 76 65 3a 20 49 74 20 69 73 20 70 6f 73 73 69 62 ve: It is possib
7040: 6c 65 20 74 6f 20 63 6f 6e 73 74 72 75 63 74 20 le to construct
7050: 74 68 65 20 72 65 73 75 6c 74 20 69 6e 20 74 68 the result in th
7060: 65 20 63 6f 72 72 65 63 74 20 6f 72 64 65 72 0a e correct order.
7070: 3b 20 20 20 75 73 69 6e 67 20 73 65 74 2d 63 64 ; using set-cd
7080: 72 21 20 74 6f 20 61 64 64 20 61 74 20 74 68 65 r! to add at the
7090: 20 74 61 69 6c 2e 20 54 68 69 73 20 72 65 6d 6f tail. This remo
70a0: 76 65 73 20 74 68 65 20 6f 76 65 72 68 65 61 64 ves the overhead
70b0: 20 6f 66 20 63 6f 70 79 69 6e 67 0a 3b 20 20 20 of copying.;
70c0: 61 74 20 74 68 65 20 65 6e 64 2c 20 61 74 20 74 at the end, at t
70d0: 68 65 20 63 6f 73 74 20 6f 66 20 6d 6f 72 65 20 he cost of more
70e0: 62 6f 6f 6b 2d 6b 65 65 70 69 6e 67 2e 0a 0a 0a book-keeping....
70f0: 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 61 (define-syntax a
7100: 70 70 65 6e 64 2d 65 63 0a 20 20 28 73 79 6e 74 ppend-ec. (synt
7110: 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 20 ax-rules ().
7120: 28 28 61 70 70 65 6e 64 2d 65 63 20 65 74 63 31 ((append-ec etc1
7130: 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 etc ...). (
7140: 61 70 70 6c 79 20 61 70 70 65 6e 64 20 28 6c 69 apply append (li
7150: 73 74 2d 65 63 20 65 74 63 31 20 65 74 63 20 2e st-ec etc1 etc .
7160: 2e 2e 29 29 20 29 29 29 0a 0a 28 64 65 66 69 6e ..)) )))..(defin
7170: 65 2d 73 79 6e 74 61 78 20 73 74 72 69 6e 67 2d e-syntax string-
7180: 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c ec. (syntax-rul
7190: 65 73 20 28 29 0a 20 20 20 20 28 28 73 74 72 69 es (). ((stri
71a0: 6e 67 2d 65 63 20 65 74 63 31 20 65 74 63 20 2e ng-ec etc1 etc .
71b0: 2e 2e 29 0a 20 20 20 20 20 28 6c 69 73 74 2d 3e ..). (list->
71c0: 73 74 72 69 6e 67 20 28 6c 69 73 74 2d 65 63 20 string (list-ec
71d0: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 29 20 29 etc1 etc ...)) )
71e0: 29 29 0a 0a 3b 20 41 6c 74 65 72 6e 61 74 69 76 ))..; Alternativ
71f0: 65 3a 20 46 6f 72 20 76 65 72 79 20 6c 6f 6e 67 e: For very long
7200: 20 73 74 72 69 6e 67 73 2c 20 74 68 65 20 69 6e strings, the in
7210: 74 65 72 6d 65 64 69 61 74 65 20 6c 69 73 74 20 termediate list
7220: 6d 61 79 20 62 65 20 61 0a 3b 20 20 20 70 72 6f may be a.; pro
7230: 62 6c 65 6d 2e 20 41 20 6d 6f 72 65 20 73 70 61 blem. A more spa
7240: 63 65 2d 61 77 61 72 65 20 69 6d 70 6c 65 6d 65 ce-aware impleme
7250: 6e 74 61 74 69 6f 6e 20 63 6f 6c 6c 65 63 74 20 ntation collect
7260: 74 68 65 20 63 68 61 72 61 63 74 65 72 73 20 0a the characters .
7270: 3b 20 20 20 69 6e 20 61 6e 20 69 6e 74 65 72 6d ; in an interm
7280: 65 64 69 61 74 65 20 6c 69 73 74 20 61 6e 64 20 ediate list and
7290: 77 68 65 6e 20 74 68 69 73 20 6c 69 73 74 20 62 when this list b
72a0: 65 63 6f 6d 65 73 20 74 6f 6f 20 6c 61 72 67 65 ecomes too large
72b0: 20 69 74 20 69 73 0a 3b 20 20 20 63 6f 6e 76 65 it is.; conve
72c0: 72 74 65 64 20 69 6e 74 6f 20 61 6e 20 69 6e 74 rted into an int
72d0: 65 72 6d 65 64 69 61 74 65 20 73 74 72 69 6e 67 ermediate string
72e0: 2e 20 41 74 20 74 68 65 20 65 6e 64 2c 20 74 68 . At the end, th
72f0: 65 20 69 6e 74 65 72 6d 65 64 69 61 74 65 0a 3b e intermediate.;
7300: 20 20 20 73 74 72 69 6e 67 73 20 61 72 65 20 63 strings are c
7310: 6f 6e 63 61 74 65 6e 61 74 65 64 20 77 69 74 68 oncatenated with
7320: 20 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 2e 0a string-append..
7330: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
7340: 20 73 74 72 69 6e 67 2d 61 70 70 65 6e 64 2d 65 string-append-e
7350: 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 c. (syntax-rule
7360: 73 20 28 29 0a 20 20 20 20 28 28 73 74 72 69 6e s (). ((strin
7370: 67 2d 61 70 70 65 6e 64 2d 65 63 20 65 74 63 31 g-append-ec etc1
7380: 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 etc ...). (
7390: 61 70 70 6c 79 20 73 74 72 69 6e 67 2d 61 70 70 apply string-app
73a0: 65 6e 64 20 28 6c 69 73 74 2d 65 63 20 65 74 63 end (list-ec etc
73b0: 31 20 65 74 63 20 2e 2e 2e 29 29 20 29 29 29 0a 1 etc ...)) ))).
73c0: 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 .(define-syntax
73d0: 76 65 63 74 6f 72 2d 65 63 0a 20 20 28 73 79 6e vector-ec. (syn
73e0: 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 20 tax-rules ().
73f0: 20 28 28 76 65 63 74 6f 72 2d 65 63 20 65 74 63 ((vector-ec etc
7400: 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 1 etc ...).
7410: 28 6c 69 73 74 2d 3e 76 65 63 74 6f 72 20 28 6c (list->vector (l
7420: 69 73 74 2d 65 63 20 65 74 63 31 20 65 74 63 20 ist-ec etc1 etc
7430: 2e 2e 2e 29 29 20 29 29 29 0a 0a 3b 20 43 6f 6d ...)) )))..; Com
7440: 6d 65 6e 74 3a 20 41 20 73 69 6d 69 6c 61 72 20 ment: A similar
7450: 61 70 70 72 6f 61 63 68 20 61 73 20 66 6f 72 20 approach as for
7460: 73 74 72 69 6e 67 2d 65 63 20 63 61 6e 20 62 65 string-ec can be
7470: 20 75 73 65 64 20 66 6f 72 20 76 65 63 74 6f 72 used for vector
7480: 2d 65 63 2e 0a 3b 20 20 20 48 6f 77 65 76 65 72 -ec..; However
7490: 2c 20 74 68 65 20 73 70 61 63 65 20 6f 76 65 72 , the space over
74a0: 68 65 61 64 20 66 6f 72 20 74 68 65 20 69 6e 74 head for the int
74b0: 65 72 6d 65 64 69 61 74 65 20 6c 69 73 74 20 69 ermediate list i
74c0: 73 20 6d 75 63 68 20 6c 6f 77 65 72 0a 3b 20 20 s much lower.;
74d0: 20 74 68 61 6e 20 66 6f 72 20 73 74 72 69 6e 67 than for string
74e0: 2d 65 63 20 61 6e 64 20 61 73 20 74 68 65 72 65 -ec and as there
74f0: 20 69 73 20 6e 6f 20 76 65 63 74 6f 72 2d 61 70 is no vector-ap
7500: 70 65 6e 64 2c 20 74 68 65 20 69 6e 74 65 72 6d pend, the interm
7510: 65 64 69 61 74 65 0a 3b 20 20 20 76 65 63 74 6f ediate.; vecto
7520: 72 73 20 6d 75 73 74 20 62 65 20 63 6f 70 69 65 rs must be copie
7530: 64 20 65 78 70 6c 69 63 69 74 6c 79 2e 0a 0a 28 d explicitly...(
7540: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 76 65 define-syntax ve
7550: 63 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d 65 ctor-of-length-e
7560: 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 c. (syntax-rule
7570: 73 20 28 6e 65 73 74 65 64 29 0a 20 20 20 20 28 s (nested). (
7580: 28 76 65 63 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 (vector-of-lengt
7590: 68 2d 65 63 20 6b 20 28 6e 65 73 74 65 64 20 71 h-ec k (nested q
75a0: 31 20 2e 2e 2e 29 20 71 20 65 74 63 31 20 65 74 1 ...) q etc1 et
75b0: 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 76 65 63 c ...). (vec
75c0: 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d 65 63 tor-of-length-ec
75d0: 20 6b 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e k (nested q1 ..
75e0: 2e 20 71 29 20 65 74 63 31 20 65 74 63 20 2e 2e . q) etc1 etc ..
75f0: 2e 29 20 29 0a 20 20 20 20 28 28 76 65 63 74 6f .) ). ((vecto
7600: 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d 65 63 20 6b r-of-length-ec k
7610: 20 71 31 20 71 32 20 20 20 20 20 20 20 20 20 20 q1 q2
7620: 20 20 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 etc1 etc ...)
7630: 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 6f 66 . (vector-of
7640: 2d 6c 65 6e 67 74 68 2d 65 63 20 6b 20 28 6e 65 -length-ec k (ne
7650: 73 74 65 64 20 71 31 20 71 32 29 20 20 20 20 65 sted q1 q2) e
7660: 74 63 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 tc1 etc ...) ).
7670: 20 20 20 28 28 76 65 63 74 6f 72 2d 6f 66 2d 6c ((vector-of-l
7680: 65 6e 67 74 68 2d 65 63 20 6b 20 65 78 70 72 65 ength-ec k expre
7690: 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 76 65 63 ssion). (vec
76a0: 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 68 2d 65 63 tor-of-length-ec
76b0: 20 6b 20 28 6e 65 73 74 65 64 29 20 65 78 70 72 k (nested) expr
76c0: 65 73 73 69 6f 6e 29 20 29 0a 0a 20 20 20 20 28 ession) ).. (
76d0: 28 76 65 63 74 6f 72 2d 6f 66 2d 6c 65 6e 67 74 (vector-of-lengt
76e0: 68 2d 65 63 20 6b 20 71 75 61 6c 69 66 69 65 72 h-ec k qualifier
76f0: 20 65 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 expression).
7700: 20 20 28 6c 65 74 20 28 28 6c 65 6e 20 6b 29 29 (let ((len k))
7710: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 . (let ((v
7720: 65 63 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 20 ec (make-vector
7730: 6c 65 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 len)).
7740: 20 20 20 28 69 20 30 29 20 29 0a 20 20 20 20 20 (i 0) ).
7750: 20 20 20 20 28 64 6f 2d 65 63 20 71 75 61 6c 69 (do-ec quali
7760: 66 69 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 fier.
7770: 20 20 20 20 20 28 69 66 20 28 3c 20 69 20 6c 65 (if (< i le
7780: 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n).
7790: 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 76 (begin (v
77a0: 65 63 74 6f 72 2d 73 65 74 21 20 76 65 63 20 69 ector-set! vec i
77b0: 20 65 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 expression).
77c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77d0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 69 20 (set! i
77e0: 28 2b 20 69 20 31 29 29 20 29 0a 20 20 20 20 20 (+ i 1)) ).
77f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7800: 65 72 72 6f 72 20 22 76 65 63 74 6f 72 20 69 73 error "vector is
7810: 20 74 6f 6f 20 73 68 6f 72 74 20 66 6f 72 20 74 too short for t
7820: 68 65 20 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e he comprehension
7830: 22 29 20 29 29 0a 20 20 20 20 20 20 20 20 20 28 ") )). (
7840: 69 66 20 28 3d 20 69 20 6c 65 6e 29 0a 20 20 20 if (= i len).
7850: 20 20 20 20 20 20 20 20 20 20 76 65 63 0a 20 20 vec.
7860: 20 20 20 20 20 20 20 20 20 20 20 28 65 72 72 6f (erro
7870: 72 20 22 76 65 63 74 6f 72 20 69 73 20 74 6f 6f r "vector is too
7880: 20 6c 6f 6e 67 20 66 6f 72 20 74 68 65 20 63 6f long for the co
7890: 6d 70 72 65 68 65 6e 73 69 6f 6e 22 29 20 29 29 mprehension") ))
78a0: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 2d 73 ))))...(define-s
78b0: 79 6e 74 61 78 20 73 75 6d 2d 65 63 0a 20 20 28 yntax sum-ec. (
78c0: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a syntax-rules ().
78d0: 20 20 20 20 28 28 73 75 6d 2d 65 63 20 65 74 63 ((sum-ec etc
78e0: 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 1 etc ...).
78f0: 28 66 6f 6c 64 2d 65 63 20 28 2b 29 20 65 74 63 (fold-ec (+) etc
7900: 31 20 65 74 63 20 2e 2e 2e 20 2b 29 20 29 29 29 1 etc ... +) )))
7910: 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 ..(define-syntax
7920: 20 70 72 6f 64 75 63 74 2d 65 63 0a 20 20 28 73 product-ec. (s
7930: 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 yntax-rules ().
7940: 20 20 20 28 28 70 72 6f 64 75 63 74 2d 65 63 20 ((product-ec
7950: 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 etc1 etc ...).
7960: 20 20 20 28 66 6f 6c 64 2d 65 63 20 28 2a 29 20 (fold-ec (*)
7970: 65 74 63 31 20 65 74 63 20 2e 2e 2e 20 2a 29 20 etc1 etc ... *)
7980: 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e )))..(define-syn
7990: 74 61 78 20 6d 69 6e 2d 65 63 0a 20 20 28 73 79 tax min-ec. (sy
79a0: 6e 74 61 78 2d 72 75 6c 65 73 20 28 29 0a 20 20 ntax-rules ().
79b0: 20 20 28 28 6d 69 6e 2d 65 63 20 65 74 63 31 20 ((min-ec etc1
79c0: 65 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 66 etc ...). (f
79d0: 6f 6c 64 33 2d 65 63 20 28 6d 69 6e 29 20 65 74 old3-ec (min) et
79e0: 63 31 20 65 74 63 20 2e 2e 2e 20 6d 69 6e 20 6d c1 etc ... min m
79f0: 69 6e 29 20 29 29 29 0a 0a 28 64 65 66 69 6e 65 in) )))..(define
7a00: 2d 73 79 6e 74 61 78 20 6d 61 78 2d 65 63 0a 20 -syntax max-ec.
7a10: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
7a20: 29 0a 20 20 20 20 28 28 6d 61 78 2d 65 63 20 65 ). ((max-ec e
7a30: 74 63 31 20 65 74 63 20 2e 2e 2e 29 0a 20 20 20 tc1 etc ...).
7a40: 20 20 28 66 6f 6c 64 33 2d 65 63 20 28 6d 61 78 (fold3-ec (max
7a50: 29 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 20 6d ) etc1 etc ... m
7a60: 61 78 20 6d 61 78 29 20 29 29 29 0a 0a 28 64 65 ax max) )))..(de
7a70: 66 69 6e 65 2d 73 79 6e 74 61 78 20 6c 61 73 74 fine-syntax last
7a80: 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 -ec. (syntax-ru
7a90: 6c 65 73 20 28 6e 65 73 74 65 64 29 0a 20 20 20 les (nested).
7aa0: 20 28 28 6c 61 73 74 2d 65 63 20 64 65 66 61 75 ((last-ec defau
7ab0: 6c 74 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e lt (nested q1 ..
7ac0: 2e 29 20 71 20 65 74 63 31 20 65 74 63 20 2e 2e .) q etc1 etc ..
7ad0: 2e 29 0a 20 20 20 20 20 28 6c 61 73 74 2d 65 63 .). (last-ec
7ae0: 20 64 65 66 61 75 6c 74 20 28 6e 65 73 74 65 64 default (nested
7af0: 20 71 31 20 2e 2e 2e 20 71 29 20 65 74 63 31 20 q1 ... q) etc1
7b00: 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 20 20 28 etc ...) ). (
7b10: 28 6c 61 73 74 2d 65 63 20 64 65 66 61 75 6c 74 (last-ec default
7b20: 20 71 31 20 71 32 20 20 20 20 20 20 20 20 20 20 q1 q2
7b30: 20 20 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 etc1 etc ...)
7b40: 0a 20 20 20 20 20 28 6c 61 73 74 2d 65 63 20 64 . (last-ec d
7b50: 65 66 61 75 6c 74 20 28 6e 65 73 74 65 64 20 71 efault (nested q
7b60: 31 20 71 32 29 20 20 20 20 65 74 63 31 20 65 74 1 q2) etc1 et
7b70: 63 20 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 6c c ...) ). ((l
7b80: 61 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 65 ast-ec default e
7b90: 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 xpression).
7ba0: 28 6c 61 73 74 2d 65 63 20 64 65 66 61 75 6c 74 (last-ec default
7bb0: 20 28 6e 65 73 74 65 64 29 20 65 78 70 72 65 73 (nested) expres
7bc0: 73 69 6f 6e 29 20 29 0a 0a 20 20 20 20 28 28 6c sion) ).. ((l
7bd0: 61 73 74 2d 65 63 20 64 65 66 61 75 6c 74 20 71 ast-ec default q
7be0: 75 61 6c 69 66 69 65 72 20 65 78 70 72 65 73 73 ualifier express
7bf0: 69 6f 6e 29 0a 20 20 20 20 20 28 6c 65 74 20 28 ion). (let (
7c00: 28 72 65 73 75 6c 74 20 64 65 66 61 75 6c 74 29 (result default)
7c10: 29 0a 20 20 20 20 20 20 20 28 64 6f 2d 65 63 20 ). (do-ec
7c20: 71 75 61 6c 69 66 69 65 72 20 28 73 65 74 21 20 qualifier (set!
7c30: 72 65 73 75 6c 74 20 65 78 70 72 65 73 73 69 6f result expressio
7c40: 6e 29 29 0a 20 20 20 20 20 20 20 72 65 73 75 6c n)). resul
7c50: 74 20 29 29 29 29 0a 0a 0a 3b 20 3d 3d 3d 3d 3d t ))))...; =====
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 3d ================
7c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ca0: 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 66 75 6e 64 =====.; The fund
7cb0: 61 6d 65 6e 74 61 6c 20 65 61 72 6c 79 2d 73 74 amental early-st
7cc0: 6f 70 70 69 6e 67 20 63 6f 6d 70 72 65 68 65 6e opping comprehen
7cd0: 73 69 6f 6e 20 66 69 72 73 74 2d 65 63 0a 3b 20 sion first-ec.;
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
7d30: 69 6e 65 2d 73 79 6e 74 61 78 20 66 69 72 73 74 ine-syntax first
7d40: 2d 65 63 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 -ec. (syntax-ru
7d50: 6c 65 73 20 28 6e 65 73 74 65 64 29 0a 20 20 20 les (nested).
7d60: 20 28 28 66 69 72 73 74 2d 65 63 20 64 65 66 61 ((first-ec defa
7d70: 75 6c 74 20 28 6e 65 73 74 65 64 20 71 31 20 2e ult (nested q1 .
7d80: 2e 2e 29 20 71 20 65 74 63 31 20 65 74 63 20 2e ..) q etc1 etc .
7d90: 2e 2e 29 0a 20 20 20 20 20 28 66 69 72 73 74 2d ..). (first-
7da0: 65 63 20 64 65 66 61 75 6c 74 20 28 6e 65 73 74 ec default (nest
7db0: 65 64 20 71 31 20 2e 2e 2e 20 71 29 20 65 74 63 ed q1 ... q) etc
7dc0: 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 20 1 etc ...) ).
7dd0: 20 28 28 66 69 72 73 74 2d 65 63 20 64 65 66 61 ((first-ec defa
7de0: 75 6c 74 20 71 31 20 71 32 20 20 20 20 20 20 20 ult q1 q2
7df0: 20 20 20 20 20 20 65 74 63 31 20 65 74 63 20 2e etc1 etc .
7e00: 2e 2e 29 0a 20 20 20 20 20 28 66 69 72 73 74 2d ..). (first-
7e10: 65 63 20 64 65 66 61 75 6c 74 20 28 6e 65 73 74 ec default (nest
7e20: 65 64 20 71 31 20 71 32 29 20 20 20 20 65 74 63 ed q1 q2) etc
7e30: 31 20 65 74 63 20 2e 2e 2e 29 20 29 0a 20 20 20 1 etc ...) ).
7e40: 20 28 28 66 69 72 73 74 2d 65 63 20 64 65 66 61 ((first-ec defa
7e50: 75 6c 74 20 65 78 70 72 65 73 73 69 6f 6e 29 0a ult expression).
7e60: 20 20 20 20 20 28 66 69 72 73 74 2d 65 63 20 64 (first-ec d
7e70: 65 66 61 75 6c 74 20 28 6e 65 73 74 65 64 29 20 efault (nested)
7e80: 65 78 70 72 65 73 73 69 6f 6e 29 20 29 0a 0a 20 expression) )..
7e90: 20 20 20 28 28 66 69 72 73 74 2d 65 63 20 64 65 ((first-ec de
7ea0: 66 61 75 6c 74 20 71 75 61 6c 69 66 69 65 72 20 fault qualifier
7eb0: 65 78 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 expression).
7ec0: 20 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 64 (let ((result d
7ed0: 65 66 61 75 6c 74 29 20 28 73 74 6f 70 20 23 66 efault) (stop #f
7ee0: 29 29 0a 20 20 20 20 20 20 20 28 65 63 2d 67 75 )). (ec-gu
7ef0: 61 72 64 65 64 2d 64 6f 2d 65 63 20 0a 20 20 20 arded-do-ec .
7f00: 20 20 20 20 20 20 73 74 6f 70 20 0a 20 20 20 20 stop .
7f10: 20 20 20 20 20 28 6e 65 73 74 65 64 20 71 75 61 (nested qua
7f20: 6c 69 66 69 65 72 29 0a 20 20 20 20 20 20 20 20 lifier).
7f30: 20 28 62 65 67 69 6e 20 28 73 65 74 21 20 72 65 (begin (set! re
7f40: 73 75 6c 74 20 65 78 70 72 65 73 73 69 6f 6e 29 sult expression)
7f50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
7f60: 20 28 73 65 74 21 20 73 74 6f 70 20 23 74 29 20 (set! stop #t)
7f70: 29 29 0a 20 20 20 20 20 20 20 72 65 73 75 6c 74 )). result
7f80: 20 29 29 29 29 0a 0a 3b 20 28 65 63 2d 67 75 61 ))))..; (ec-gua
7f90: 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 rded-do-ec stop
7fa0: 28 6e 65 73 74 65 64 20 71 20 2e 2e 2e 29 20 63 (nested q ...) c
7fb0: 6d 64 29 0a 3b 20 20 20 63 6f 6e 73 74 72 75 63 md).; construc
7fc0: 74 73 20 28 64 6f 2d 65 63 20 71 20 2e 2e 2e 20 ts (do-ec q ...
7fd0: 63 6d 64 29 20 77 68 65 72 65 20 74 68 65 20 67 cmd) where the g
7fe0: 65 6e 65 72 61 74 6f 72 73 20 67 65 6e 20 69 6e enerators gen in
7ff0: 20 71 20 2e 2e 2e 20 61 72 65 0a 3b 20 20 20 72 q ... are.; r
8000: 65 70 6c 61 63 65 64 20 62 79 20 28 3a 75 6e 74 eplaced by (:unt
8010: 69 6c 20 67 65 6e 20 73 74 6f 70 29 2e 0a 0a 28 il gen stop)...(
8020: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 65 63 define-syntax ec
8030: 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 0a 20 -guarded-do-ec.
8040: 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 (syntax-rules (
8050: 6e 65 73 74 65 64 20 69 66 20 6e 6f 74 20 61 6e nested if not an
8060: 64 20 6f 72 20 62 65 67 69 6e 29 0a 0a 20 20 20 d or begin)..
8070: 20 28 28 65 63 2d 67 75 61 72 64 65 64 2d 64 6f ((ec-guarded-do
8080: 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 64 -ec stop (nested
8090: 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 29 (nested q1 ...)
80a0: 20 71 32 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 q2 ...) cmd).
80b0: 20 20 20 28 65 63 2d 67 75 61 72 64 65 64 2d 64 (ec-guarded-d
80c0: 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 o-ec stop (neste
80d0: 64 20 71 31 20 2e 2e 2e 20 71 32 20 2e 2e 2e 29 d q1 ... q2 ...)
80e0: 20 63 6d 64 29 20 29 0a 0a 20 20 20 20 28 28 65 cmd) ).. ((e
80f0: 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 c-guarded-do-ec
8100: 73 74 6f 70 20 28 6e 65 73 74 65 64 20 28 69 66 stop (nested (if
8110: 20 74 65 73 74 29 20 71 20 2e 2e 2e 29 20 63 6d test) q ...) cm
8120: 64 29 0a 20 20 20 20 20 28 69 66 20 74 65 73 74 d). (if test
8130: 20 28 65 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d (ec-guarded-do-
8140: 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 64 20 ec stop (nested
8150: 71 20 2e 2e 2e 29 20 63 6d 64 29 29 20 29 0a 20 q ...) cmd)) ).
8160: 20 20 20 28 28 65 63 2d 67 75 61 72 64 65 64 2d ((ec-guarded-
8170: 64 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 do-ec stop (nest
8180: 65 64 20 28 6e 6f 74 20 74 65 73 74 29 20 71 20 ed (not test) q
8190: 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 20 28 ...) cmd). (
81a0: 69 66 20 28 6e 6f 74 20 74 65 73 74 29 20 28 65 if (not test) (e
81b0: 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 c-guarded-do-ec
81c0: 73 74 6f 70 20 28 6e 65 73 74 65 64 20 71 20 2e stop (nested q .
81d0: 2e 2e 29 20 63 6d 64 29 29 20 29 0a 20 20 20 20 ..) cmd)) ).
81e0: 28 28 65 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d ((ec-guarded-do-
81f0: 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 64 20 ec stop (nested
8200: 28 61 6e 64 20 74 65 73 74 20 2e 2e 2e 29 20 71 (and test ...) q
8210: 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 20 ...) cmd).
8220: 28 69 66 20 28 61 6e 64 20 74 65 73 74 20 2e 2e (if (and test ..
8230: 2e 29 20 28 65 63 2d 67 75 61 72 64 65 64 2d 64 .) (ec-guarded-d
8240: 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 73 74 65 o-ec stop (neste
8250: 64 20 71 20 2e 2e 2e 29 20 63 6d 64 29 29 20 29 d q ...) cmd)) )
8260: 0a 20 20 20 20 28 28 65 63 2d 67 75 61 72 64 65 . ((ec-guarde
8270: 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 d-do-ec stop (ne
8280: 73 74 65 64 20 28 6f 72 20 74 65 73 74 20 2e 2e sted (or test ..
8290: 2e 29 20 71 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 .) q ...) cmd).
82a0: 20 20 20 20 28 69 66 20 28 6f 72 20 74 65 73 74 (if (or test
82b0: 20 2e 2e 2e 29 20 28 65 63 2d 67 75 61 72 64 65 ...) (ec-guarde
82c0: 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 28 6e 65 d-do-ec stop (ne
82d0: 73 74 65 64 20 71 20 2e 2e 2e 29 20 63 6d 64 29 sted q ...) cmd)
82e0: 29 20 29 0a 0a 20 20 20 20 28 28 65 63 2d 67 75 ) ).. ((ec-gu
82f0: 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 arded-do-ec stop
8300: 20 28 6e 65 73 74 65 64 20 28 62 65 67 69 6e 20 (nested (begin
8310: 65 74 63 20 2e 2e 2e 29 20 71 20 2e 2e 2e 29 20 etc ...) q ...)
8320: 63 6d 64 29 0a 20 20 20 20 20 28 62 65 67 69 6e cmd). (begin
8330: 20 65 74 63 20 2e 2e 2e 20 28 65 63 2d 67 75 61 etc ... (ec-gua
8340: 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 20 rded-do-ec stop
8350: 28 6e 65 73 74 65 64 20 71 20 2e 2e 2e 29 20 63 (nested q ...) c
8360: 6d 64 29 29 20 29 0a 0a 20 20 20 20 28 28 65 63 md)) ).. ((ec
8370: 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 -guarded-do-ec s
8380: 74 6f 70 20 28 6e 65 73 74 65 64 20 67 65 6e 20 top (nested gen
8390: 71 20 2e 2e 2e 29 20 63 6d 64 29 0a 20 20 20 20 q ...) cmd).
83a0: 20 28 64 6f 2d 65 63 20 0a 20 20 20 20 20 20 20 (do-ec .
83b0: 28 3a 75 6e 74 69 6c 20 67 65 6e 20 73 74 6f 70 (:until gen stop
83c0: 29 20 0a 20 20 20 20 20 20 20 28 65 63 2d 67 75 ) . (ec-gu
83d0: 61 72 64 65 64 2d 64 6f 2d 65 63 20 73 74 6f 70 arded-do-ec stop
83e0: 20 28 6e 65 73 74 65 64 20 71 20 2e 2e 2e 29 20 (nested q ...)
83f0: 63 6d 64 29 20 29 29 0a 0a 20 20 20 20 28 28 65 cmd) )).. ((e
8400: 63 2d 67 75 61 72 64 65 64 2d 64 6f 2d 65 63 20 c-guarded-do-ec
8410: 73 74 6f 70 20 28 6e 65 73 74 65 64 29 20 63 6d stop (nested) cm
8420: 64 29 0a 20 20 20 20 20 28 64 6f 2d 65 63 20 63 d). (do-ec c
8430: 6d 64 29 20 29 29 29 0a 0a 3b 20 41 6c 74 65 72 md) )))..; Alter
8440: 6e 61 74 69 76 65 3a 20 49 6e 73 74 65 61 64 20 native: Instead
8450: 6f 66 20 6d 6f 64 69 66 79 69 6e 67 20 74 68 65 of modifying the
8460: 20 67 65 6e 65 72 61 74 6f 72 20 77 69 74 68 20 generator with
8470: 3a 75 6e 74 69 6c 2c 20 69 74 20 69 73 0a 3b 20 :until, it is.;
8480: 20 20 70 6f 73 73 69 62 6c 65 20 74 6f 20 75 73 possible to us
8490: 65 20 63 61 6c 6c 2d 77 69 74 68 2d 63 75 72 72 e call-with-curr
84a0: 65 6e 74 2d 63 6f 6e 74 69 6e 75 61 74 69 6f 6e ent-continuation
84b0: 3a 0a 3b 0a 3b 20 20 20 28 64 65 66 69 6e 65 2d :.;.; (define-
84c0: 73 79 6e 61 74 78 20 66 69 72 73 74 2d 65 63 20 synatx first-ec
84d0: 0a 3b 20 20 20 20 20 2e 2e 2e 73 61 6d 65 20 61 .; ...same a
84e0: 73 20 61 62 6f 76 65 2e 2e 2e 0a 3b 20 20 20 20 s above....;
84f0: 20 28 28 66 69 72 73 74 2d 65 63 20 64 65 66 61 ((first-ec defa
8500: 75 6c 74 20 71 75 61 6c 69 66 69 65 72 20 65 78 ult qualifier ex
8510: 70 72 65 73 73 69 6f 6e 29 0a 3b 20 20 20 20 20 pression).;
8520: 20 28 63 61 6c 6c 2d 77 69 74 68 2d 63 75 72 72 (call-with-curr
8530: 65 6e 74 2d 63 6f 6e 74 69 6e 75 61 74 69 6f 6e ent-continuation
8540: 20 0a 3b 20 20 20 20 20 20 20 28 6c 61 6d 62 64 .; (lambd
8550: 61 20 28 63 63 29 0a 3b 20 20 20 20 20 20 20 20 a (cc).;
8560: 28 64 6f 2d 65 63 20 71 75 61 6c 69 66 69 65 72 (do-ec qualifier
8570: 20 28 63 63 20 65 78 70 72 65 73 73 69 6f 6e 29 (cc expression)
8580: 29 0a 3b 20 20 20 20 20 20 20 20 64 65 66 61 75 ).; defau
8590: 6c 74 20 29 29 29 20 29 29 0a 3b 0a 3b 20 20 20 lt ))) )).;.;
85a0: 54 68 69 73 20 69 73 20 6d 75 63 68 20 73 69 6d This is much sim
85b0: 70 6c 65 72 20 62 75 74 20 6e 6f 74 20 6e 65 63 pler but not nec
85c0: 65 73 73 61 72 69 6c 79 20 61 73 20 65 66 66 69 essarily as effi
85d0: 63 69 65 6e 74 2e 0a 0a 0a 3b 20 3d 3d 3d 3d 3d cient....; =====
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 3d ================
8600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8620: 3d 3d 3d 3d 3d 0a 3b 20 54 68 65 20 65 61 72 6c =====.; The earl
8630: 79 2d 73 74 6f 70 70 69 6e 67 20 63 6f 6d 70 72 y-stopping compr
8640: 65 68 65 6e 73 69 6f 6e 73 20 61 6e 79 3f 2d 65 ehensions any?-e
8650: 63 20 65 76 65 72 79 3f 2d 65 63 0a 3b 20 3d 3d c every?-ec.; ==
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86a0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
86b0: 65 2d 73 79 6e 74 61 78 20 61 6e 79 3f 2d 65 63 e-syntax any?-ec
86c0: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
86d0: 20 28 6e 65 73 74 65 64 29 0a 20 20 20 20 28 28 (nested). ((
86e0: 61 6e 79 3f 2d 65 63 20 28 6e 65 73 74 65 64 20 any?-ec (nested
86f0: 71 31 20 2e 2e 2e 29 20 71 20 65 74 63 31 20 65 q1 ...) q etc1 e
8700: 74 63 20 2e 2e 2e 29 0a 20 20 20 20 20 28 61 6e tc ...). (an
8710: 79 3f 2d 65 63 20 28 6e 65 73 74 65 64 20 71 31 y?-ec (nested q1
8720: 20 2e 2e 2e 20 71 29 20 65 74 63 31 20 65 74 63 ... q) etc1 etc
8730: 20 2e 2e 2e 29 20 29 0a 20 20 20 20 28 28 61 6e ...) ). ((an
8740: 79 3f 2d 65 63 20 71 31 20 71 32 20 20 20 20 20 y?-ec q1 q2
8750: 20 20 20 20 20 20 20 20 65 74 63 31 20 65 74 63 etc1 etc
8760: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 61 6e 79 3f ...). (any?
8770: 2d 65 63 20 28 6e 65 73 74 65 64 20 71 31 20 71 -ec (nested q1 q
8780: 32 29 20 20 20 20 65 74 63 31 20 65 74 63 20 2e 2) etc1 etc .
8790: 2e 2e 29 20 29 0a 20 20 20 20 28 28 61 6e 79 3f ..) ). ((any?
87a0: 2d 65 63 20 65 78 70 72 65 73 73 69 6f 6e 29 0a -ec expression).
87b0: 20 20 20 20 20 28 61 6e 79 3f 2d 65 63 20 28 6e (any?-ec (n
87c0: 65 73 74 65 64 29 20 65 78 70 72 65 73 73 69 6f ested) expressio
87d0: 6e 29 20 29 0a 0a 20 20 20 20 28 28 61 6e 79 3f n) ).. ((any?
87e0: 2d 65 63 20 71 75 61 6c 69 66 69 65 72 20 65 78 -ec qualifier ex
87f0: 70 72 65 73 73 69 6f 6e 29 0a 20 20 20 20 20 28 pression). (
8800: 66 69 72 73 74 2d 65 63 20 23 66 20 71 75 61 6c first-ec #f qual
8810: 69 66 69 65 72 20 28 69 66 20 65 78 70 72 65 73 ifier (if expres
8820: 73 69 6f 6e 29 20 23 74 29 20 29 29 29 0a 0a 28 sion) #t) )))..(
8830: 64 65 66 69 6e 65 2d 73 79 6e 74 61 78 20 65 76 define-syntax ev
8840: 65 72 79 3f 2d 65 63 0a 20 20 28 73 79 6e 74 61 ery?-ec. (synta
8850: 78 2d 72 75 6c 65 73 20 28 6e 65 73 74 65 64 29 x-rules (nested)
8860: 0a 20 20 20 20 28 28 65 76 65 72 79 3f 2d 65 63 . ((every?-ec
8870: 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 29 (nested q1 ...)
8880: 20 71 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 q etc1 etc ...)
8890: 0a 20 20 20 20 20 28 65 76 65 72 79 3f 2d 65 63 . (every?-ec
88a0: 20 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 20 (nested q1 ...
88b0: 71 29 20 65 74 63 31 20 65 74 63 20 2e 2e 2e 29 q) etc1 etc ...)
88c0: 20 29 0a 20 20 20 20 28 28 65 76 65 72 79 3f 2d ). ((every?-
88d0: 65 63 20 71 31 20 71 32 20 20 20 20 20 20 20 20 ec q1 q2
88e0: 20 20 20 20 20 65 74 63 31 20 65 74 63 20 2e 2e etc1 etc ..
88f0: 2e 29 0a 20 20 20 20 20 28 65 76 65 72 79 3f 2d .). (every?-
8900: 65 63 20 28 6e 65 73 74 65 64 20 71 31 20 71 32 ec (nested q1 q2
8910: 29 20 20 20 20 65 74 63 31 20 65 74 63 20 2e 2e ) etc1 etc ..
8920: 2e 29 20 29 0a 20 20 20 20 28 28 65 76 65 72 79 .) ). ((every
8930: 3f 2d 65 63 20 65 78 70 72 65 73 73 69 6f 6e 29 ?-ec expression)
8940: 0a 20 20 20 20 20 28 65 76 65 72 79 3f 2d 65 63 . (every?-ec
8950: 20 28 6e 65 73 74 65 64 29 20 65 78 70 72 65 73 (nested) expres
8960: 73 69 6f 6e 29 20 29 0a 0a 20 20 20 20 28 28 65 sion) ).. ((e
8970: 76 65 72 79 3f 2d 65 63 20 71 75 61 6c 69 66 69 very?-ec qualifi
8980: 65 72 20 65 78 70 72 65 73 73 69 6f 6e 29 0a 20 er expression).
8990: 20 20 20 20 28 66 69 72 73 74 2d 65 63 20 23 74 (first-ec #t
89a0: 20 71 75 61 6c 69 66 69 65 72 20 28 69 66 20 28 qualifier (if (
89b0: 6e 6f 74 20 65 78 70 72 65 73 73 69 6f 6e 29 29 not expression))
89c0: 20 23 66 29 20 29 29 29 0a 0a 20 20 0a 0a 29 0a #f) ))).. ..).