Artifact
25ff0f711344498efaa985104d2b0622e6958818:
- File
srfi/s78/check.scm
— part of check-in
[80c8c83034]
at
2016-07-07 18:11:39
on branch trunk
— initial import
(user:
ovenpasta@pizzahack.eu
size: 9907)
0000: 3b 20 3c 50 4c 41 49 4e 54 45 58 54 3e 0a 3b 20 ; <PLAINTEXT>.;
0010: 43 6f 70 79 72 69 67 68 74 20 28 63 29 20 32 30 Copyright (c) 20
0020: 30 35 2d 32 30 30 36 20 53 65 62 61 73 74 69 61 05-2006 Sebastia
0030: 6e 20 45 67 6e 65 72 2e 0a 3b 20 0a 3b 20 50 65 n Egner..; .; Pe
0040: 72 6d 69 73 73 69 6f 6e 20 69 73 20 68 65 72 65 rmission is here
0050: 62 79 20 67 72 61 6e 74 65 64 2c 20 66 72 65 65 by granted, free
0060: 20 6f 66 20 63 68 61 72 67 65 2c 20 74 6f 20 61 of charge, to a
0070: 6e 79 20 70 65 72 73 6f 6e 20 6f 62 74 61 69 6e ny person obtain
0080: 69 6e 67 0a 3b 20 61 20 63 6f 70 79 20 6f 66 20 ing.; a copy of
0090: 74 68 69 73 20 73 6f 66 74 77 61 72 65 20 61 6e this software an
00a0: 64 20 61 73 73 6f 63 69 61 74 65 64 20 64 6f 63 d associated doc
00b0: 75 6d 65 6e 74 61 74 69 6f 6e 20 66 69 6c 65 73 umentation files
00c0: 20 28 74 68 65 0a 3b 20 60 60 53 6f 66 74 77 61 (the.; ``Softwa
00d0: 72 65 27 27 29 2c 20 74 6f 20 64 65 61 6c 20 69 re''), to deal i
00e0: 6e 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 77 n the Software w
00f0: 69 74 68 6f 75 74 20 72 65 73 74 72 69 63 74 69 ithout restricti
0100: 6f 6e 2c 20 69 6e 63 6c 75 64 69 6e 67 0a 3b 20 on, including.;
0110: 77 69 74 68 6f 75 74 20 6c 69 6d 69 74 61 74 69 without limitati
0120: 6f 6e 20 74 68 65 20 72 69 67 68 74 73 20 74 6f on the rights to
0130: 20 75 73 65 2c 20 63 6f 70 79 2c 20 6d 6f 64 69 use, copy, modi
0140: 66 79 2c 20 6d 65 72 67 65 2c 20 70 75 62 6c 69 fy, merge, publi
0150: 73 68 2c 0a 3b 20 64 69 73 74 72 69 62 75 74 65 sh,.; distribute
0160: 2c 20 73 75 62 6c 69 63 65 6e 73 65 2c 20 61 6e , sublicense, an
0170: 64 2f 6f 72 20 73 65 6c 6c 20 63 6f 70 69 65 73 d/or sell copies
0180: 20 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 65 of the Software
0190: 2c 20 61 6e 64 20 74 6f 0a 3b 20 70 65 72 6d 69 , and to.; permi
01a0: 74 20 70 65 72 73 6f 6e 73 20 74 6f 20 77 68 6f t persons to who
01b0: 6d 20 74 68 65 20 53 6f 66 74 77 61 72 65 20 69 m the Software i
01c0: 73 20 66 75 72 6e 69 73 68 65 64 20 74 6f 20 64 s furnished to d
01d0: 6f 20 73 6f 2c 20 73 75 62 6a 65 63 74 20 74 6f o so, subject to
01e0: 0a 3b 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 .; the following
01f0: 20 63 6f 6e 64 69 74 69 6f 6e 73 3a 0a 3b 20 0a conditions:.; .
0200: 3b 20 54 68 65 20 61 62 6f 76 65 20 63 6f 70 79 ; The above copy
0210: 72 69 67 68 74 20 6e 6f 74 69 63 65 20 61 6e 64 right notice and
0220: 20 74 68 69 73 20 70 65 72 6d 69 73 73 69 6f 6e this permission
0230: 20 6e 6f 74 69 63 65 20 73 68 61 6c 6c 20 62 65 notice shall be
0240: 0a 3b 20 69 6e 63 6c 75 64 65 64 20 69 6e 20 61 .; included in a
0250: 6c 6c 20 63 6f 70 69 65 73 20 6f 72 20 73 75 62 ll copies or sub
0260: 73 74 61 6e 74 69 61 6c 20 70 6f 72 74 69 6f 6e stantial portion
0270: 73 20 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 s of the Softwar
0280: 65 2e 0a 3b 20 0a 3b 20 54 48 45 20 53 4f 46 54 e..; .; THE SOFT
0290: 57 41 52 45 20 49 53 20 50 52 4f 56 49 44 45 44 WARE IS PROVIDED
02a0: 20 60 60 41 53 20 49 53 27 27 2c 20 57 49 54 48 ``AS IS'', WITH
02b0: 4f 55 54 20 57 41 52 52 41 4e 54 59 20 4f 46 20 OUT WARRANTY OF
02c0: 41 4e 59 20 4b 49 4e 44 2c 0a 3b 20 45 58 50 52 ANY KIND,.; EXPR
02d0: 45 53 53 20 4f 52 20 49 4d 50 4c 49 45 44 2c 20 ESS OR IMPLIED,
02e0: 49 4e 43 4c 55 44 49 4e 47 20 42 55 54 20 4e 4f INCLUDING BUT NO
02f0: 54 20 4c 49 4d 49 54 45 44 20 54 4f 20 54 48 45 T LIMITED TO THE
0300: 20 57 41 52 52 41 4e 54 49 45 53 20 4f 46 0a 3b WARRANTIES OF.;
0310: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0320: 2c 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 , FITNESS FOR A
0330: 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f PARTICULAR PURPO
0340: 53 45 20 41 4e 44 0a 3b 20 4e 4f 4e 49 4e 46 52 SE AND.; NONINFR
0350: 49 4e 47 45 4d 45 4e 54 2e 20 49 4e 20 4e 4f 20 INGEMENT. IN NO
0360: 45 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 20 EVENT SHALL THE
0370: 41 55 54 48 4f 52 53 20 4f 52 20 43 4f 50 59 52 AUTHORS OR COPYR
0380: 49 47 48 54 20 48 4f 4c 44 45 52 53 20 42 45 0a IGHT HOLDERS BE.
0390: 3b 20 4c 49 41 42 4c 45 20 46 4f 52 20 41 4e 59 ; LIABLE FOR ANY
03a0: 20 43 4c 41 49 4d 2c 20 44 41 4d 41 47 45 53 20 CLAIM, DAMAGES
03b0: 4f 52 20 4f 54 48 45 52 20 4c 49 41 42 49 4c 49 OR OTHER LIABILI
03c0: 54 59 2c 20 57 48 45 54 48 45 52 20 49 4e 20 41 TY, WHETHER IN A
03d0: 4e 20 41 43 54 49 4f 4e 0a 3b 20 4f 46 20 43 4f N ACTION.; OF CO
03e0: 4e 54 52 41 43 54 2c 20 54 4f 52 54 20 4f 52 20 NTRACT, TORT OR
03f0: 4f 54 48 45 52 57 49 53 45 2c 20 41 52 49 53 49 OTHERWISE, ARISI
0400: 4e 47 20 46 52 4f 4d 2c 20 4f 55 54 20 4f 46 20 NG FROM, OUT OF
0410: 4f 52 20 49 4e 20 43 4f 4e 4e 45 43 54 49 4f 4e OR IN CONNECTION
0420: 0a 3b 20 57 49 54 48 20 54 48 45 20 53 4f 46 54 .; WITH THE SOFT
0430: 57 41 52 45 20 4f 52 20 54 48 45 20 55 53 45 20 WARE OR THE USE
0440: 4f 52 20 4f 54 48 45 52 20 44 45 41 4c 49 4e 47 OR OTHER DEALING
0450: 53 20 49 4e 20 54 48 45 20 53 4f 46 54 57 41 52 S IN THE SOFTWAR
0460: 45 2e 0a 3b 20 0a 3b 20 2d 2d 2d 2d 2d 2d 2d 2d E..; .; --------
0470: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0480: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
0490: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
04a0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 0a ---------------.
04b0: 3b 20 4d 6f 64 69 66 69 65 64 20 62 79 20 44 65 ; Modified by De
04c0: 72 69 63 6b 20 45 64 64 69 6e 67 74 6f 6e 20 74 rick Eddington t
04d0: 6f 20 70 72 69 6e 74 20 74 68 69 6e 67 73 20 61 o print things a
04e0: 20 6c 69 74 74 6c 65 20 64 69 66 66 65 72 65 6e little differen
04f0: 74 6c 79 2e 0a 3b 20 0a 3b 20 4c 69 67 68 74 77 tly..; .; Lightw
0500: 65 69 67 68 74 20 74 65 73 74 69 6e 67 20 28 72 eight testing (r
0510: 65 66 65 72 65 6e 63 65 20 69 6d 70 6c 65 6d 65 eference impleme
0520: 6e 74 61 74 69 6f 6e 29 0a 3b 20 3d 3d 3d 3d 3d ntation).; =====
0530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 0a 3b 20 53 65 =========.;.; Se
0560: 62 61 73 74 69 61 6e 2e 45 67 6e 65 72 40 70 68 bastian.Egner@ph
0570: 69 6c 69 70 73 2e 63 6f 6d 0a 3b 20 69 6e 20 52 ilips.com.; in R
0580: 35 52 53 20 2b 20 53 52 46 49 20 32 33 20 28 65 5RS + SRFI 23 (e
0590: 72 72 6f 72 29 20 2b 20 53 52 46 49 20 34 32 20 rror) + SRFI 42
05a0: 28 63 6f 6d 70 72 65 68 65 6e 73 69 6f 6e 73 29 (comprehensions)
05b0: 0a 3b 0a 3b 20 68 69 73 74 6f 72 79 20 6f 66 20 .;.; history of
05c0: 74 68 69 73 20 66 69 6c 65 3a 0a 3b 20 20 20 53 this file:.; S
05d0: 45 2c 20 32 35 2d 4f 63 74 2d 32 30 30 34 3a 20 E, 25-Oct-2004:
05e0: 66 69 72 73 74 20 76 65 72 73 69 6f 6e 20 62 61 first version ba
05f0: 73 65 64 20 6f 6e 20 63 6f 64 65 20 75 73 65 64 sed on code used
0600: 20 69 6e 20 53 52 46 49 73 20 34 32 20 61 6e 64 in SRFIs 42 and
0610: 20 36 37 0a 3b 20 20 20 53 45 2c 20 31 39 2d 4a 67.; SE, 19-J
0620: 61 6e 2d 32 30 30 36 3a 20 28 61 72 67 20 2e 2e an-2006: (arg ..
0630: 2e 29 20 6d 61 64 65 20 6f 70 74 69 6f 6e 61 6c .) made optional
0640: 20 69 6e 20 63 68 65 63 6b 2d 65 63 0a 3b 0a 3b in check-ec.;.;
0650: 20 4e 61 6d 69 6e 67 20 63 6f 6e 76 65 6e 74 69 Naming conventi
0660: 6f 6e 20 22 63 68 65 63 6b 3a 3c 69 64 65 6e 74 on "check:<ident
0670: 69 66 69 65 72 3e 22 20 69 73 20 75 73 65 64 20 ifier>" is used
0680: 6f 6e 6c 79 20 69 6e 74 65 72 6e 61 6c 6c 79 2e only internally.
0690: 0a 0a 3b 20 2d 2d 20 70 6f 72 74 61 62 69 6c 69 ..; -- portabili
06a0: 74 79 20 2d 2d 0a 0a 3b 20 50 4c 54 3a 20 20 20 ty --..; PLT:
06b0: 20 20 20 28 72 65 71 75 69 72 65 20 28 6c 69 62 (require (lib
06c0: 20 22 32 33 2e 73 73 22 20 22 73 72 66 69 22 29 "23.ss" "srfi")
06d0: 20 28 6c 69 62 20 22 34 32 2e 73 73 22 20 22 73 (lib "42.ss" "s
06e0: 72 66 69 22 29 29 0a 3b 20 53 63 68 65 6d 65 34 rfi")).; Scheme4
06f0: 38 3a 20 2c 6f 70 65 6e 20 73 72 66 69 2d 32 33 8: ,open srfi-23
0700: 20 73 72 66 69 2d 34 32 20 0a 0a 3b 20 2d 2d 20 srfi-42 ..; --
0710: 75 74 69 6c 69 74 69 65 73 20 2d 2d 0a 0a 23 3b utilities --..#;
0720: 28 64 65 66 69 6e 65 20 63 68 65 63 6b 3a 77 72 (define check:wr
0730: 69 74 65 20 77 72 69 74 65 29 0a 0a 28 64 65 66 ite write)..(def
0740: 69 6e 65 20 28 70 72 69 6e 74 2f 68 65 61 64 65 ine (print/heade
0750: 72 2f 70 61 64 64 65 64 20 78 20 68 65 61 64 65 r/padded x heade
0760: 72 20 70 61 64 64 69 6e 67 29 0a 20 20 28 64 65 r padding). (de
0770: 66 69 6e 65 20 28 70 72 69 6e 74 2f 6c 69 6e 65 fine (print/line
0780: 73 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 73 s). (let* ((s
0790: 74 72 20 28 63 61 6c 6c 2d 77 69 74 68 2d 73 74 tr (call-with-st
07a0: 72 69 6e 67 2d 6f 75 74 70 75 74 2d 70 6f 72 74 ring-output-port
07b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
07c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 73 6f 70 29 (lambda (sop)
07d0: 20 28 63 68 65 63 6b 3a 77 72 69 74 65 20 78 20 (check:write x
07e0: 73 6f 70 29 29 29 29 0a 20 20 20 20 20 20 20 20 sop)))).
07f0: 20 20 20 28 73 69 70 20 28 6f 70 65 6e 2d 73 74 (sip (open-st
0800: 72 69 6e 67 2d 69 6e 70 75 74 2d 70 6f 72 74 20 ring-input-port
0810: 73 74 72 29 29 29 0a 20 20 20 20 20 20 28 6c 65 str))). (le
0820: 74 20 6c 6f 6f 70 20 28 28 6c 69 6e 65 73 20 27 t loop ((lines '
0830: 28 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 65 ())). (le
0840: 74 20 28 28 6c 20 28 67 65 74 2d 6c 69 6e 65 20 t ((l (get-line
0850: 73 69 70 29 29 29 0a 20 20 20 20 20 20 20 20 20 sip))).
0860: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object
0870: 3f 20 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ? l).
0880: 20 28 72 65 76 65 72 73 65 20 6c 69 6e 65 73 29 (reverse lines)
0890: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f . (lo
08a0: 6f 70 20 28 63 6f 6e 73 20 6c 20 6c 69 6e 65 73 op (cons l lines
08b0: 29 29 29 29 29 29 29 0a 20 20 28 6c 65 74 20 28 ))))))). (let (
08c0: 28 6c 69 6e 65 73 20 28 70 72 69 6e 74 2f 6c 69 (lines (print/li
08d0: 6e 65 73 29 29 29 0a 20 20 20 20 28 64 69 73 70 nes))). (disp
08e0: 6c 61 79 20 68 65 61 64 65 72 29 0a 20 20 20 20 lay header).
08f0: 28 64 69 73 70 6c 61 79 20 28 63 61 72 20 6c 69 (display (car li
0900: 6e 65 73 29 29 0a 20 20 20 20 28 6c 65 74 20 6c nes)). (let l
0910: 6f 6f 70 20 28 28 6c 69 6e 65 73 20 28 63 64 72 oop ((lines (cdr
0920: 20 6c 69 6e 65 73 29 29 29 0a 20 20 20 20 20 20 lines))).
0930: 28 75 6e 6c 65 73 73 20 28 6e 75 6c 6c 3f 20 6c (unless (null? l
0940: 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 28 6e ines). (n
0950: 65 77 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 20 ewline).
0960: 28 64 69 73 70 6c 61 79 20 70 61 64 64 69 6e 67 (display padding
0970: 29 0a 20 20 20 20 20 20 20 20 28 64 69 73 70 6c ). (displ
0980: 61 79 20 28 63 61 72 20 6c 69 6e 65 73 29 29 0a ay (car lines)).
0990: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 (loop (c
09a0: 64 72 20 6c 69 6e 65 73 29 29 29 29 29 29 0a 0a dr lines))))))..
09b0: 3b 20 59 6f 75 20 63 61 6e 20 61 6c 73 6f 20 75 ; You can also u
09c0: 73 65 20 61 20 70 72 65 74 74 79 20 70 72 69 6e se a pretty prin
09d0: 74 65 72 20 69 66 20 79 6f 75 20 68 61 76 65 20 ter if you have
09e0: 6f 6e 65 2e 0a 3b 20 48 6f 77 65 76 65 72 2c 20 one..; However,
09f0: 74 68 65 20 6f 75 74 70 75 74 20 6d 69 67 68 74 the output might
0a00: 20 6e 6f 74 20 69 6d 70 72 6f 76 65 20 66 6f 72 not improve for
0a10: 20 6d 6f 73 74 20 63 61 73 65 73 0a 3b 20 62 65 most cases.; be
0a20: 63 61 75 73 65 20 74 68 65 20 70 72 65 74 74 79 cause the pretty
0a30: 20 70 72 69 6e 74 65 72 73 20 75 73 75 61 6c 6c printers usuall
0a40: 79 20 6f 75 74 70 75 74 20 61 20 74 72 61 69 6c y output a trail
0a50: 69 6e 67 0a 3b 20 6e 65 77 6c 69 6e 65 2e 0a 0a ing.; newline...
0a60: 3b 20 50 4c 54 3a 20 20 20 20 20 20 28 72 65 71 ; PLT: (req
0a70: 75 69 72 65 20 28 6c 69 62 20 22 70 72 65 74 74 uire (lib "prett
0a80: 79 2e 73 73 22 29 29 20 28 64 65 66 69 6e 65 20 y.ss")) (define
0a90: 63 68 65 63 6b 3a 77 72 69 74 65 20 70 72 65 74 check:write pret
0aa0: 74 79 2d 70 72 69 6e 74 29 0a 3b 20 53 63 68 65 ty-print).; Sche
0ab0: 6d 65 34 38 3a 20 2c 6f 70 65 6e 20 70 70 20 28 me48: ,open pp (
0ac0: 64 65 66 69 6e 65 20 63 68 65 63 6b 3a 77 72 69 define check:wri
0ad0: 74 65 20 70 29 0a 0a 3b 20 2d 2d 20 6d 6f 64 65 te p)..; -- mode
0ae0: 20 2d 2d 0a 0a 28 64 65 66 69 6e 65 20 63 68 65 --..(define che
0af0: 63 6b 3a 6d 6f 64 65 20 0a 20 20 28 6d 61 6b 65 ck:mode . (make
0b00: 2d 70 61 72 61 6d 65 74 65 72 20 27 72 65 70 6f -parameter 'repo
0b10: 72 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 rt.
0b20: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 29 (lambda (v)
0b30: 20 28 63 61 73 65 20 76 0a 20 20 20 20 20 20 20 (case v.
0b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b50: 20 20 20 20 20 20 20 20 20 28 28 6f 66 66 29 20 ((off)
0b60: 20 20 20 20 20 20 20 20 20 20 30 29 0a 20 20 20 0).
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
0b90: 75 6d 6d 61 72 79 29 20 20 20 20 20 20 20 31 29 ummary) 1)
0ba0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0bc0: 20 28 28 72 65 70 6f 72 74 2d 66 61 69 6c 65 64 ((report-failed
0bd0: 29 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 20 ) 10).
0be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0bf0: 20 20 20 20 20 20 28 28 72 65 70 6f 72 74 29 20 ((report)
0c00: 20 20 20 20 20 20 20 31 30 30 29 0a 20 20 20 20 100).
0c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c20: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
0c30: 65 20 28 65 72 72 6f 72 20 22 75 6e 72 65 63 6f e (error "unreco
0c40: 67 6e 69 7a 65 64 20 6d 6f 64 65 22 20 76 29 29 gnized mode" v))
0c50: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
0c60: 68 65 63 6b 2d 73 65 74 2d 6d 6f 64 65 21 20 6d heck-set-mode! m
0c70: 6f 64 65 29 0a 20 20 28 63 68 65 63 6b 3a 6d 6f ode). (check:mo
0c80: 64 65 20 6d 6f 64 65 29 29 0a 0a 3b 20 2d 2d 20 de mode))..; --
0c90: 73 74 61 74 65 20 2d 2d 0a 0a 28 64 65 66 69 6e state --..(defin
0ca0: 65 20 63 68 65 63 6b 3a 63 6f 72 72 65 63 74 20 e check:correct
0cb0: 30 29 0a 28 64 65 66 69 6e 65 20 63 68 65 63 6b 0).(define check
0cc0: 3a 66 61 69 6c 65 64 20 27 28 29 29 0a 0a 28 64 :failed '())..(d
0cd0: 65 66 69 6e 65 20 28 63 68 65 63 6b 2d 72 65 73 efine (check-res
0ce0: 65 74 21 29 0a 20 20 28 73 65 74 21 20 63 68 65 et!). (set! che
0cf0: 63 6b 3a 63 6f 72 72 65 63 74 20 30 29 0a 20 20 ck:correct 0).
0d00: 28 73 65 74 21 20 63 68 65 63 6b 3a 66 61 69 6c (set! check:fail
0d10: 65 64 20 20 20 27 28 29 29 29 0a 0a 28 64 65 66 ed '()))..(def
0d20: 69 6e 65 20 28 63 68 65 63 6b 3a 61 64 64 2d 63 ine (check:add-c
0d30: 6f 72 72 65 63 74 21 29 0a 20 20 28 73 65 74 21 orrect!). (set!
0d40: 20 63 68 65 63 6b 3a 63 6f 72 72 65 63 74 20 28 check:correct (
0d50: 2b 20 63 68 65 63 6b 3a 63 6f 72 72 65 63 74 20 + check:correct
0d60: 31 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 1)))..(define (c
0d70: 68 65 63 6b 3a 61 64 64 2d 66 61 69 6c 65 64 21 heck:add-failed!
0d80: 20 65 78 70 72 65 73 73 69 6f 6e 20 61 63 74 75 expression actu
0d90: 61 6c 2d 72 65 73 75 6c 74 20 65 78 70 65 63 74 al-result expect
0da0: 65 64 2d 72 65 73 75 6c 74 20 70 72 65 64 29 0a ed-result pred).
0db0: 20 20 28 73 65 74 21 20 63 68 65 63 6b 3a 66 61 (set! check:fa
0dc0: 69 6c 65 64 0a 20 20 20 20 20 20 20 20 28 63 6f iled. (co
0dd0: 6e 73 20 28 6c 69 73 74 20 65 78 70 72 65 73 73 ns (list express
0de0: 69 6f 6e 20 61 63 74 75 61 6c 2d 72 65 73 75 6c ion actual-resul
0df0: 74 20 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c t expected-resul
0e00: 74 20 70 72 65 64 29 0a 20 20 20 20 20 20 20 20 t pred).
0e10: 20 20 20 20 20 20 63 68 65 63 6b 3a 66 61 69 6c check:fail
0e20: 65 64 29 29 29 0a 0a 3b 20 2d 2d 20 72 65 70 6f ed)))..; -- repo
0e30: 72 74 69 6e 67 20 2d 2d 0a 0a 28 64 65 66 69 6e rting --..(defin
0e40: 65 20 28 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d e (check:report-
0e50: 65 78 70 72 65 73 73 69 6f 6e 20 65 78 70 72 65 expression expre
0e60: 73 73 69 6f 6e 20 70 72 65 64 29 0a 20 20 28 6e ssion pred). (n
0e70: 65 77 6c 69 6e 65 29 0a 20 20 28 63 68 65 63 6b ewline). (check
0e80: 3a 77 72 69 74 65 20 65 78 70 72 65 73 73 69 6f :write expressio
0e90: 6e 29 0a 20 20 28 69 66 20 70 72 65 64 0a 20 20 n). (if pred.
0ea0: 20 20 28 62 65 67 69 6e 20 28 70 72 69 6e 74 2f (begin (print/
0eb0: 68 65 61 64 65 72 2f 70 61 64 64 65 64 20 70 72 header/padded pr
0ec0: 65 64 20 22 28 3d 3e 20 22 20 22 20 20 20 20 22 ed "(=> " " "
0ed0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 64 69 ). (di
0ee0: 73 70 6c 61 79 20 22 29 5c 6e 22 29 29 0a 20 20 splay ")\n")).
0ef0: 20 20 28 64 69 73 70 6c 61 79 20 22 3d 3e 5c 6e (display "=>\n
0f00: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ")))..(define (c
0f10: 68 65 63 6b 3a 72 65 70 6f 72 74 2d 61 63 74 75 heck:report-actu
0f20: 61 6c 2d 72 65 73 75 6c 74 20 61 63 74 75 61 6c al-result actual
0f30: 2d 72 65 73 75 6c 74 29 0a 20 20 28 63 68 65 63 -result). (chec
0f40: 6b 3a 77 72 69 74 65 20 61 63 74 75 61 6c 2d 72 k:write actual-r
0f50: 65 73 75 6c 74 29 29 0a 0a 28 64 65 66 69 6e 65 esult))..(define
0f60: 20 28 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d 63 (check:report-c
0f70: 6f 72 72 65 63 74 20 63 61 73 65 73 29 0a 20 20 orrect cases).
0f80: 28 64 69 73 70 6c 61 79 20 22 3b 20 63 6f 72 72 (display "; corr
0f90: 65 63 74 22 29 0a 20 20 28 69 66 20 28 6e 6f 74 ect"). (if (not
0fa0: 20 28 3d 20 63 61 73 65 73 20 31 29 29 0a 20 20 (= cases 1)).
0fb0: 20 20 20 20 28 62 65 67 69 6e 20 28 64 69 73 70 (begin (disp
0fc0: 6c 61 79 20 22 20 28 22 29 0a 20 20 20 20 20 20 lay " (").
0fd0: 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 (display
0fe0: 63 61 73 65 73 29 0a 20 20 20 20 20 20 20 20 20 cases).
0ff0: 20 20 20 20 28 64 69 73 70 6c 61 79 20 22 20 63 (display " c
1000: 61 73 65 73 20 63 68 65 63 6b 65 64 29 22 29 29 ases checked)"))
1010: 29 0a 20 20 28 6e 65 77 6c 69 6e 65 29 29 0a 0a ). (newline))..
1020: 28 64 65 66 69 6e 65 20 28 63 68 65 63 6b 3a 72 (define (check:r
1030: 65 70 6f 72 74 2d 66 61 69 6c 65 64 20 65 78 70 eport-failed exp
1040: 65 63 74 65 64 2d 72 65 73 75 6c 74 29 0a 20 20 ected-result).
1050: 28 64 69 73 70 6c 61 79 20 22 3b 20 2a 2a 2a 20 (display "; ***
1060: 66 61 69 6c 65 64 20 2a 2a 2a 5c 6e 22 29 0a 20 failed ***\n").
1070: 20 28 70 72 69 6e 74 2f 68 65 61 64 65 72 2f 70 (print/header/p
1080: 61 64 64 65 64 20 65 78 70 65 63 74 65 64 2d 72 added expected-r
1090: 65 73 75 6c 74 20 22 3b 20 65 78 70 65 63 74 65 esult "; expecte
10a0: 64 20 72 65 73 75 6c 74 3a 20 22 0a 20 20 20 20 d result: ".
10b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10d0: 20 20 20 22 3b 20 20 20 20 20 20 20 20 20 20 20 ";
10e0: 20 20 20 20 20 20 20 22 29 0a 20 20 28 6e 65 77 "). (new
10f0: 6c 69 6e 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 line))..(define
1100: 28 63 68 65 63 6b 2d 72 65 70 6f 72 74 29 0a 20 (check-report).
1110: 20 28 69 66 20 28 3e 3d 20 28 63 68 65 63 6b 3a (if (>= (check:
1120: 6d 6f 64 65 29 20 31 29 0a 20 20 20 20 20 20 28 mode) 1). (
1130: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 6e begin. (n
1140: 65 77 6c 69 6e 65 29 0a 20 20 20 20 20 20 20 20 ewline).
1150: 28 64 69 73 70 6c 61 79 20 22 3b 20 2a 2a 2a 20 (display "; ***
1160: 63 68 65 63 6b 73 20 2a 2a 2a 20 3a 20 22 29 0a checks *** : ").
1170: 20 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 (display
1180: 20 63 68 65 63 6b 3a 63 6f 72 72 65 63 74 29 0a check:correct).
1190: 20 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 (display
11a0: 20 22 20 63 6f 72 72 65 63 74 2c 20 22 29 0a 20 " correct, ").
11b0: 20 20 20 20 20 20 20 28 64 69 73 70 6c 61 79 20 (display
11c0: 28 6c 65 6e 67 74 68 20 63 68 65 63 6b 3a 66 61 (length check:fa
11d0: 69 6c 65 64 29 29 0a 20 20 20 20 20 20 20 20 28 iled)). (
11e0: 64 69 73 70 6c 61 79 20 22 20 66 61 69 6c 65 64 display " failed
11f0: 2e 22 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ."). (if
1200: 28 6f 72 20 28 6e 75 6c 6c 3f 20 63 68 65 63 6b (or (null? check
1210: 3a 66 61 69 6c 65 64 29 20 28 3c 3d 20 28 63 68 :failed) (<= (ch
1220: 65 63 6b 3a 6d 6f 64 65 29 20 31 29 29 0a 20 20 eck:mode) 1)).
1230: 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 6c 69 (newli
1240: 6e 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ne).
1250: 28 6c 65 74 2a 20 28 28 77 20 28 63 61 72 20 28 (let* ((w (car (
1260: 72 65 76 65 72 73 65 20 63 68 65 63 6b 3a 66 61 reverse check:fa
1270: 69 6c 65 64 29 29 29 0a 20 20 20 20 20 20 20 20 iled))).
1280: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 70 72 (expr
1290: 65 73 73 69 6f 6e 20 28 63 61 72 20 77 29 29 0a ession (car w)).
12a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12b0: 20 20 20 28 61 63 74 75 61 6c 2d 72 65 73 75 6c (actual-resul
12c0: 74 20 28 63 61 64 72 20 77 29 29 0a 20 20 20 20 t (cadr w)).
12d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
12e0: 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c 74 20 expected-result
12f0: 28 63 61 64 64 72 20 77 29 29 0a 20 20 20 20 20 (caddr w)).
1300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
1310: 72 65 64 20 28 63 61 64 64 64 72 20 77 29 29 29 red (cadddr w)))
1320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1330: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1340: 20 28 64 69 73 70 6c 61 79 20 22 20 46 69 72 73 (display " Firs
1350: 74 20 66 61 69 6c 65 64 20 65 78 61 6d 70 6c 65 t failed example
1360: 3a 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 :").
1370: 20 20 28 6e 65 77 6c 69 6e 65 29 0a 20 20 20 20 (newline).
1380: 20 20 20 20 20 20 20 20 20 20 28 63 68 65 63 6b (check
1390: 3a 72 65 70 6f 72 74 2d 65 78 70 72 65 73 73 69 :report-expressi
13a0: 6f 6e 20 65 78 70 72 65 73 73 69 6f 6e 20 70 72 on expression pr
13b0: 65 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ed).
13c0: 20 20 28 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d (check:report-
13d0: 61 63 74 75 61 6c 2d 72 65 73 75 6c 74 20 61 63 actual-result ac
13e0: 74 75 61 6c 2d 72 65 73 75 6c 74 29 0a 20 20 20 tual-result).
13f0: 20 20 20 20 20 20 20 20 20 20 20 28 63 68 65 63 (chec
1400: 6b 3a 72 65 70 6f 72 74 2d 66 61 69 6c 65 64 20 k:report-failed
1410: 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c 74 29 expected-result)
1420: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
1430: 63 68 65 63 6b 2d 70 61 73 73 65 64 3f 20 65 78 check-passed? ex
1440: 70 65 63 74 65 64 2d 74 6f 74 61 6c 2d 63 6f 75 pected-total-cou
1450: 6e 74 29 0a 20 20 28 61 6e 64 20 28 3d 20 28 6c nt). (and (= (l
1460: 65 6e 67 74 68 20 63 68 65 63 6b 3a 66 61 69 6c ength check:fail
1470: 65 64 29 20 30 29 0a 20 20 20 20 20 20 20 28 3d ed) 0). (=
1480: 20 63 68 65 63 6b 3a 63 6f 72 72 65 63 74 20 65 check:correct e
1490: 78 70 65 63 74 65 64 2d 74 6f 74 61 6c 2d 63 6f xpected-total-co
14a0: 75 6e 74 29 29 29 0a 20 20 20 20 20 20 20 0a 3b unt))). .;
14b0: 20 2d 2d 20 73 69 6d 70 6c 65 20 63 68 65 63 6b -- simple check
14c0: 73 20 2d 2d 0a 0a 28 64 65 66 69 6e 65 20 28 63 s --..(define (c
14d0: 68 65 63 6b 3a 70 72 6f 63 20 65 78 70 72 65 73 heck:proc expres
14e0: 73 69 6f 6e 20 74 68 75 6e 6b 20 65 71 75 61 6c sion thunk equal
14f0: 20 65 71 75 61 6c 2d 65 78 70 72 20 65 78 70 65 equal-expr expe
1500: 63 74 65 64 2d 72 65 73 75 6c 74 29 0a 20 20 28 cted-result). (
1510: 63 61 73 65 20 28 63 68 65 63 6b 3a 6d 6f 64 65 case (check:mode
1520: 29 0a 20 20 20 20 28 28 30 29 20 23 66 29 0a 20 ). ((0) #f).
1530: 20 20 20 28 28 31 29 0a 20 20 20 20 20 28 6c 65 ((1). (le
1540: 74 20 28 28 61 63 74 75 61 6c 2d 72 65 73 75 6c t ((actual-resul
1550: 74 20 28 74 68 75 6e 6b 29 29 29 0a 20 20 20 20 t (thunk))).
1560: 20 20 20 28 69 66 20 28 65 71 75 61 6c 20 61 63 (if (equal ac
1570: 74 75 61 6c 2d 72 65 73 75 6c 74 20 65 78 70 65 tual-result expe
1580: 63 74 65 64 2d 72 65 73 75 6c 74 29 0a 20 20 20 cted-result).
1590: 20 20 20 20 20 20 20 20 28 63 68 65 63 6b 3a 61 (check:a
15a0: 64 64 2d 63 6f 72 72 65 63 74 21 29 0a 20 20 20 dd-correct!).
15b0: 20 20 20 20 20 20 20 20 28 63 68 65 63 6b 3a 61 (check:a
15c0: 64 64 2d 66 61 69 6c 65 64 21 0a 20 20 20 20 20 dd-failed!.
15d0: 20 20 20 20 20 20 20 65 78 70 72 65 73 73 69 6f expressio
15e0: 6e 20 61 63 74 75 61 6c 2d 72 65 73 75 6c 74 20 n actual-result
15f0: 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c 74 20 expected-result
1600: 65 71 75 61 6c 2d 65 78 70 72 29 29 29 29 0a 20 equal-expr)))).
1610: 20 20 20 28 28 31 30 29 0a 20 20 20 20 20 28 6c ((10). (l
1620: 65 74 20 28 28 61 63 74 75 61 6c 2d 72 65 73 75 et ((actual-resu
1630: 6c 74 20 28 74 68 75 6e 6b 29 29 29 0a 20 20 20 lt (thunk))).
1640: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 20 61 (if (equal a
1650: 63 74 75 61 6c 2d 72 65 73 75 6c 74 20 65 78 70 ctual-result exp
1660: 65 63 74 65 64 2d 72 65 73 75 6c 74 29 0a 20 20 ected-result).
1670: 20 20 20 20 20 20 20 20 20 28 63 68 65 63 6b 3a (check:
1680: 61 64 64 2d 63 6f 72 72 65 63 74 21 29 0a 20 20 add-correct!).
1690: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
16a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 68 (ch
16b0: 65 63 6b 3a 72 65 70 6f 72 74 2d 65 78 70 72 65 eck:report-expre
16c0: 73 73 69 6f 6e 20 65 78 70 72 65 73 73 69 6f 6e ssion expression
16d0: 20 65 71 75 61 6c 2d 65 78 70 72 29 0a 20 20 20 equal-expr).
16e0: 20 20 20 20 20 20 20 20 20 20 28 63 68 65 63 6b (check
16f0: 3a 72 65 70 6f 72 74 2d 61 63 74 75 61 6c 2d 72 :report-actual-r
1700: 65 73 75 6c 74 20 61 63 74 75 61 6c 2d 72 65 73 esult actual-res
1710: 75 6c 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ult).
1720: 20 20 28 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d (check:report-
1730: 66 61 69 6c 65 64 20 65 78 70 65 63 74 65 64 2d failed expected-
1740: 72 65 73 75 6c 74 29 0a 20 20 20 20 20 20 20 20 result).
1750: 20 20 20 20 20 28 63 68 65 63 6b 3a 61 64 64 2d (check:add-
1760: 66 61 69 6c 65 64 21 0a 20 20 20 20 20 20 20 20 failed!.
1770: 20 20 20 20 20 20 65 78 70 72 65 73 73 69 6f 6e expression
1780: 20 61 63 74 75 61 6c 2d 72 65 73 75 6c 74 20 65 actual-result e
1790: 78 70 65 63 74 65 64 2d 72 65 73 75 6c 74 20 65 xpected-result e
17a0: 71 75 61 6c 2d 65 78 70 72 29 29 29 29 29 0a 20 qual-expr))))).
17b0: 20 20 20 28 28 31 30 30 29 0a 20 20 20 20 20 28 ((100). (
17c0: 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d 65 78 70 check:report-exp
17d0: 72 65 73 73 69 6f 6e 20 65 78 70 72 65 73 73 69 ression expressi
17e0: 6f 6e 20 65 71 75 61 6c 2d 65 78 70 72 29 0a 20 on equal-expr).
17f0: 20 20 20 20 28 6c 65 74 20 28 28 61 63 74 75 61 (let ((actua
1800: 6c 2d 72 65 73 75 6c 74 20 28 74 68 75 6e 6b 29 l-result (thunk)
1810: 29 29 0a 20 20 20 20 20 20 20 28 63 68 65 63 6b )). (check
1820: 3a 72 65 70 6f 72 74 2d 61 63 74 75 61 6c 2d 72 :report-actual-r
1830: 65 73 75 6c 74 20 61 63 74 75 61 6c 2d 72 65 73 esult actual-res
1840: 75 6c 74 29 0a 20 20 20 20 20 20 20 28 69 66 20 ult). (if
1850: 28 65 71 75 61 6c 20 61 63 74 75 61 6c 2d 72 65 (equal actual-re
1860: 73 75 6c 74 20 65 78 70 65 63 74 65 64 2d 72 65 sult expected-re
1870: 73 75 6c 74 29 0a 20 20 20 20 20 20 20 20 20 20 sult).
1880: 20 28 62 65 67 69 6e 20 28 63 68 65 63 6b 3a 72 (begin (check:r
1890: 65 70 6f 72 74 2d 63 6f 72 72 65 63 74 20 31 29 eport-correct 1)
18a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
18b0: 20 20 20 28 63 68 65 63 6b 3a 61 64 64 2d 63 6f (check:add-co
18c0: 72 72 65 63 74 21 29 29 0a 20 20 20 20 20 20 20 rrect!)).
18d0: 20 20 20 20 28 62 65 67 69 6e 20 28 63 68 65 63 (begin (chec
18e0: 6b 3a 72 65 70 6f 72 74 2d 66 61 69 6c 65 64 20 k:report-failed
18f0: 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c 74 29 expected-result)
1900: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1910: 20 20 20 28 63 68 65 63 6b 3a 61 64 64 2d 66 61 (check:add-fa
1920: 69 6c 65 64 21 0a 20 20 20 20 20 20 20 20 20 20 iled!.
1930: 20 20 20 20 20 20 20 20 20 65 78 70 72 65 73 73 express
1940: 69 6f 6e 20 61 63 74 75 61 6c 2d 72 65 73 75 6c ion actual-resul
1950: 74 20 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c t expected-resul
1960: 74 20 65 71 75 61 6c 2d 65 78 70 72 29 29 29 29 t equal-expr))))
1970: 29 0a 20 20 20 20 28 65 6c 73 65 20 28 65 72 72 ). (else (err
1980: 6f 72 20 22 75 6e 72 65 63 6f 67 6e 69 7a 65 64 or "unrecognized
1990: 20 63 68 65 63 6b 3a 6d 6f 64 65 22 20 28 63 68 check:mode" (ch
19a0: 65 63 6b 3a 6d 6f 64 65 29 29 29 29 0a 20 20 28 eck:mode)))). (
19b0: 69 66 20 23 66 20 23 66 29 29 0a 0a 28 64 65 66 if #f #f))..(def
19c0: 69 6e 65 2d 73 79 6e 74 61 78 20 63 68 65 63 6b ine-syntax check
19d0: 0a 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 . (syntax-rules
19e0: 20 28 3d 3e 29 0a 20 20 20 20 28 28 63 68 65 63 (=>). ((chec
19f0: 6b 20 65 78 70 72 20 3d 3e 20 65 78 70 65 63 74 k expr => expect
1a00: 65 64 29 0a 20 20 20 20 20 28 69 66 20 28 3e 3d ed). (if (>=
1a10: 20 28 63 68 65 63 6b 3a 6d 6f 64 65 29 20 31 29 (check:mode) 1)
1a20: 0a 09 20 28 63 68 65 63 6b 3a 70 72 6f 63 20 27 .. (check:proc '
1a30: 65 78 70 72 20 28 6c 61 6d 62 64 61 20 28 29 20 expr (lambda ()
1a40: 65 78 70 72 29 20 65 71 75 61 6c 3f 20 23 46 20 expr) equal? #F
1a50: 65 78 70 65 63 74 65 64 29 29 29 0a 20 20 20 20 expected))).
1a60: 28 28 63 68 65 63 6b 20 65 78 70 72 20 28 3d 3e ((check expr (=>
1a70: 20 65 71 75 61 6c 29 20 65 78 70 65 63 74 65 64 equal) expected
1a80: 29 0a 20 20 20 20 20 28 69 66 20 28 3e 3d 20 28 ). (if (>= (
1a90: 63 68 65 63 6b 3a 6d 6f 64 65 29 20 31 29 0a 09 check:mode) 1)..
1aa0: 20 28 63 68 65 63 6b 3a 70 72 6f 63 20 27 65 78 (check:proc 'ex
1ab0: 70 72 20 28 6c 61 6d 62 64 61 20 28 29 20 65 78 pr (lambda () ex
1ac0: 70 72 29 20 65 71 75 61 6c 20 27 65 71 75 61 6c pr) equal 'equal
1ad0: 20 65 78 70 65 63 74 65 64 29 29 29 29 29 0a 0a expected)))))..
1ae0: 3b 20 2d 2d 20 70 61 72 61 6d 65 74 72 69 63 20 ; -- parametric
1af0: 63 68 65 63 6b 73 20 2d 2d 0a 0a 28 64 65 66 69 checks --..(defi
1b00: 6e 65 20 28 63 68 65 63 6b 3a 70 72 6f 63 2d 65 ne (check:proc-e
1b10: 63 20 77 29 0a 20 20 28 6c 65 74 20 28 28 63 6f c w). (let ((co
1b20: 72 72 65 63 74 3f 20 28 63 61 72 20 77 29 29 0a rrect? (car w)).
1b30: 20 20 20 20 20 20 20 20 28 65 78 70 72 65 73 73 (express
1b40: 69 6f 6e 20 28 63 61 64 72 20 77 29 29 0a 20 20 ion (cadr w)).
1b50: 20 20 20 20 20 20 28 61 63 74 75 61 6c 2d 72 65 (actual-re
1b60: 73 75 6c 74 20 28 63 61 64 64 72 20 77 29 29 0a sult (caddr w)).
1b70: 20 20 20 20 20 20 20 20 28 65 78 70 65 63 74 65 (expecte
1b80: 64 2d 72 65 73 75 6c 74 20 28 63 61 64 64 64 72 d-result (cadddr
1b90: 20 77 29 29 0a 09 28 63 61 73 65 73 20 28 63 61 w))..(cases (ca
1ba0: 72 20 28 63 64 64 64 64 72 20 77 29 29 29 0a 20 r (cddddr w))).
1bb0: 20 20 20 20 20 20 20 28 65 71 75 61 6c 2d 65 78 (equal-ex
1bc0: 70 72 20 28 63 61 64 72 20 28 63 64 64 64 64 72 pr (cadr (cddddr
1bd0: 20 77 29 29 29 29 0a 20 20 20 20 28 69 66 20 63 w)))). (if c
1be0: 6f 72 72 65 63 74 3f 0a 20 20 20 20 20 20 20 20 orrect?.
1bf0: 28 62 65 67 69 6e 20 28 69 66 20 28 3e 3d 20 28 (begin (if (>= (
1c00: 63 68 65 63 6b 3a 6d 6f 64 65 29 20 31 30 30 29 check:mode) 100)
1c10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
1c20: 20 20 20 20 28 62 65 67 69 6e 20 28 63 68 65 63 (begin (chec
1c30: 6b 3a 72 65 70 6f 72 74 2d 65 78 70 72 65 73 73 k:report-express
1c40: 69 6f 6e 20 65 78 70 72 65 73 73 69 6f 6e 20 65 ion expression e
1c50: 71 75 61 6c 2d 65 78 70 72 29 0a 20 20 20 20 20 qual-expr).
1c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1c70: 20 20 20 20 20 28 63 68 65 63 6b 3a 72 65 70 6f (check:repo
1c80: 72 74 2d 61 63 74 75 61 6c 2d 72 65 73 75 6c 74 rt-actual-result
1c90: 20 61 63 74 75 61 6c 2d 72 65 73 75 6c 74 29 0a actual-result).
1ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1cb0: 20 20 20 20 20 20 20 20 20 20 28 63 68 65 63 6b (check
1cc0: 3a 72 65 70 6f 72 74 2d 63 6f 72 72 65 63 74 20 :report-correct
1cd0: 63 61 73 65 73 29 29 29 0a 20 20 20 20 20 20 20 cases))).
1ce0: 20 20 20 20 20 20 20 20 28 63 68 65 63 6b 3a 61 (check:a
1cf0: 64 64 2d 63 6f 72 72 65 63 74 21 29 29 0a 20 20 dd-correct!)).
1d00: 20 20 20 20 20 20 28 62 65 67 69 6e 20 28 69 66 (begin (if
1d10: 20 28 3e 3d 20 28 63 68 65 63 6b 3a 6d 6f 64 65 (>= (check:mode
1d20: 29 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 20 ) 10).
1d30: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 20 (begin
1d40: 28 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d 65 78 (check:report-ex
1d50: 70 72 65 73 73 69 6f 6e 20 65 78 70 72 65 73 73 pression express
1d60: 69 6f 6e 20 65 71 75 61 6c 2d 65 78 70 72 29 0a ion equal-expr).
1d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1d80: 20 20 20 20 20 20 20 20 20 20 28 63 68 65 63 6b (check
1d90: 3a 72 65 70 6f 72 74 2d 61 63 74 75 61 6c 2d 72 :report-actual-r
1da0: 65 73 75 6c 74 20 61 63 74 75 61 6c 2d 72 65 73 esult actual-res
1db0: 75 6c 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ult).
1dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1dd0: 63 68 65 63 6b 3a 72 65 70 6f 72 74 2d 66 61 69 check:report-fai
1de0: 6c 65 64 20 65 78 70 65 63 74 65 64 2d 72 65 73 led expected-res
1df0: 75 6c 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 ult))).
1e00: 20 20 20 20 20 20 28 63 68 65 63 6b 3a 61 64 64 (check:add
1e10: 2d 66 61 69 6c 65 64 21 0a 20 20 20 20 20 20 20 -failed!.
1e20: 20 20 20 20 20 20 20 20 20 65 78 70 72 65 73 73 express
1e30: 69 6f 6e 20 61 63 74 75 61 6c 2d 72 65 73 75 6c ion actual-resul
1e40: 74 20 65 78 70 65 63 74 65 64 2d 72 65 73 75 6c t expected-resul
1e50: 74 20 65 71 75 61 6c 2d 65 78 70 72 29 29 29 29 t equal-expr))))
1e60: 29 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e 74 61 )..(define-synta
1e70: 78 20 63 68 65 63 6b 2d 65 63 3a 6d 61 6b 65 0a x check-ec:make.
1e80: 20 20 28 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 (syntax-rules
1e90: 28 3d 3e 29 0a 20 20 20 20 28 28 63 68 65 63 6b (=>). ((check
1ea0: 2d 65 63 3a 6d 61 6b 65 20 71 75 61 6c 69 66 69 -ec:make qualifi
1eb0: 65 72 73 20 65 78 70 72 20 28 3d 3e 20 65 71 75 ers expr (=> equ
1ec0: 61 6c 29 20 65 78 70 65 63 74 65 64 20 28 61 72 al) expected (ar
1ed0: 67 20 2e 2e 2e 29 29 0a 20 20 20 20 20 28 69 66 g ...)). (if
1ee0: 20 28 3e 3d 20 28 63 68 65 63 6b 3a 6d 6f 64 65 (>= (check:mode
1ef0: 29 20 31 29 0a 20 20 20 20 20 20 20 20 20 28 63 ) 1). (c
1f00: 68 65 63 6b 3a 70 72 6f 63 2d 65 63 0a 09 20 20 heck:proc-ec..
1f10: 28 6c 65 74 20 28 28 63 61 73 65 73 20 30 29 29 (let ((cases 0))
1f20: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 77 20 28 .. (let ((w (
1f30: 66 69 72 73 74 2d 65 63 20 0a 09 09 20 20 20 20 first-ec ...
1f40: 20 20 23 66 0a 09 09 20 20 20 20 20 20 71 75 61 #f... qua
1f50: 6c 69 66 69 65 72 73 0a 09 09 20 20 20 20 20 20 lifiers...
1f60: 28 3a 6c 65 74 20 65 71 75 61 6c 2d 70 72 65 64 (:let equal-pred
1f70: 20 65 71 75 61 6c 29 0a 09 09 20 20 20 20 20 20 equal)...
1f80: 28 3a 6c 65 74 20 65 78 70 65 63 74 65 64 2d 72 (:let expected-r
1f90: 65 73 75 6c 74 20 65 78 70 65 63 74 65 64 29 0a esult expected).
1fa0: 09 09 20 20 20 20 20 20 28 3a 6c 65 74 20 61 63 .. (:let ac
1fb0: 74 75 61 6c 2d 72 65 73 75 6c 74 0a 20 20 20 20 tual-result.
1fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fd0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 61 (let ((a
1fe0: 72 67 20 61 72 67 29 20 2e 2e 2e 29 20 3b 20 28 rg arg) ...) ; (
1ff0: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2010: 20 65 78 70 72 29 29 0a 09 09 20 20 20 20 20 20 expr))...
2020: 28 62 65 67 69 6e 20 28 73 65 74 21 20 63 61 73 (begin (set! cas
2030: 65 73 20 28 2b 20 63 61 73 65 73 20 31 29 29 29 es (+ cases 1)))
2040: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ... (if (no
2050: 74 20 28 65 71 75 61 6c 2d 70 72 65 64 20 61 63 t (equal-pred ac
2060: 74 75 61 6c 2d 72 65 73 75 6c 74 20 65 78 70 65 tual-result expe
2070: 63 74 65 64 2d 72 65 73 75 6c 74 29 29 29 0a 09 cted-result)))..
2080: 09 20 20 20 20 20 20 28 6c 69 73 74 20 28 6c 69 . (list (li
2090: 73 74 20 27 6c 65 74 20 28 6c 69 73 74 20 28 6c st 'let (list (l
20a0: 69 73 74 20 27 61 72 67 20 61 72 67 29 20 2e 2e ist 'arg arg) ..
20b0: 2e 29 20 27 65 78 70 72 29 0a 09 09 09 20 20 20 .) 'expr)....
20c0: 20 61 63 74 75 61 6c 2d 72 65 73 75 6c 74 0a 09 actual-result..
20d0: 09 09 20 20 20 20 65 78 70 65 63 74 65 64 2d 72 .. expected-r
20e0: 65 73 75 6c 74 0a 09 09 09 20 20 20 20 63 61 73 esult.... cas
20f0: 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 es.
2100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 '
2110: 65 71 75 61 6c 29 29 29 29 0a 09 20 20 20 20 20 equal))))..
2120: 20 28 69 66 20 77 0a 09 09 20 20 28 63 6f 6e 73 (if w... (cons
2130: 20 23 66 20 77 29 0a 09 09 20 20 28 6c 69 73 74 #f w)... (list
2140: 20 23 74 20 0a 09 09 09 27 28 63 68 65 63 6b 2d #t ....'(check-
2150: 65 63 20 71 75 61 6c 69 66 69 65 72 73 20 0a 09 ec qualifiers ..
2160: 09 09 09 20 20 20 65 78 70 72 20 28 3d 3e 20 65 ... expr (=> e
2170: 71 75 61 6c 29 20 0a 09 09 09 09 20 20 20 65 78 qual) ..... ex
2180: 70 65 63 74 65 64 20 28 61 72 67 20 2e 2e 2e 29 pected (arg ...)
2190: 29 0a 09 09 09 28 69 66 20 23 66 20 23 66 29 0a )....(if #f #f).
21a0: 09 09 20 20 20 20 20 20 20 20 28 69 66 20 23 66 .. (if #f
21b0: 20 23 66 29 0a 09 09 09 63 61 73 65 73 0a 20 20 #f)....cases.
21c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21d0: 20 20 20 20 20 20 27 65 71 75 61 6c 29 29 29 29 'equal))))
21e0: 29 29 29 29 29 0a 0a 3b 20 28 2a 29 20 69 73 20 )))))..; (*) is
21f0: 61 20 63 6f 6d 70 69 6c 65 2d 74 69 6d 65 20 63 a compile-time c
2200: 68 65 63 6b 20 74 68 61 74 20 28 61 72 67 20 2e heck that (arg .
2210: 2e 2e 29 20 69 73 20 61 20 6c 69 73 74 0a 3b 20 ..) is a list.;
2220: 6f 66 20 70 61 69 72 77 69 73 65 20 64 69 73 6a of pairwise disj
2230: 6f 69 6e 74 20 62 6f 75 6e 64 20 76 61 72 69 61 oint bound varia
2240: 62 6c 65 73 20 61 74 20 74 68 69 73 20 70 6f 69 bles at this poi
2250: 6e 74 2e 0a 0a 28 64 65 66 69 6e 65 2d 73 79 6e nt...(define-syn
2260: 74 61 78 20 63 68 65 63 6b 2d 65 63 0a 20 20 28 tax check-ec. (
2270: 73 79 6e 74 61 78 2d 72 75 6c 65 73 20 28 6e 65 syntax-rules (ne
2280: 73 74 65 64 20 3d 3e 29 0a 20 20 20 20 28 28 63 sted =>). ((c
2290: 68 65 63 6b 2d 65 63 20 65 78 70 72 20 3d 3e 20 heck-ec expr =>
22a0: 65 78 70 65 63 74 65 64 29 0a 20 20 20 20 20 28 expected). (
22b0: 63 68 65 63 6b 2d 65 63 3a 6d 61 6b 65 20 28 6e check-ec:make (n
22c0: 65 73 74 65 64 29 20 65 78 70 72 20 28 3d 3e 20 ested) expr (=>
22d0: 65 71 75 61 6c 3f 29 20 65 78 70 65 63 74 65 64 equal?) expected
22e0: 20 28 29 29 29 0a 20 20 20 20 28 28 63 68 65 63 ())). ((chec
22f0: 6b 2d 65 63 20 65 78 70 72 20 28 3d 3e 20 65 71 k-ec expr (=> eq
2300: 75 61 6c 29 20 65 78 70 65 63 74 65 64 29 0a 20 ual) expected).
2310: 20 20 20 20 28 63 68 65 63 6b 2d 65 63 3a 6d 61 (check-ec:ma
2320: 6b 65 20 28 6e 65 73 74 65 64 29 20 65 78 70 72 ke (nested) expr
2330: 20 28 3d 3e 20 65 71 75 61 6c 29 20 65 78 70 65 (=> equal) expe
2340: 63 74 65 64 20 28 29 29 29 0a 20 20 20 20 28 28 cted ())). ((
2350: 63 68 65 63 6b 2d 65 63 20 65 78 70 72 20 3d 3e check-ec expr =>
2360: 20 65 78 70 65 63 74 65 64 20 28 61 72 67 20 2e expected (arg .
2370: 2e 2e 29 29 0a 20 20 20 20 20 28 63 68 65 63 6b ..)). (check
2380: 2d 65 63 3a 6d 61 6b 65 20 28 6e 65 73 74 65 64 -ec:make (nested
2390: 29 20 65 78 70 72 20 28 3d 3e 20 65 71 75 61 6c ) expr (=> equal
23a0: 3f 29 20 65 78 70 65 63 74 65 64 20 28 61 72 67 ?) expected (arg
23b0: 20 2e 2e 2e 29 29 29 0a 20 20 20 20 28 28 63 68 ...))). ((ch
23c0: 65 63 6b 2d 65 63 20 65 78 70 72 20 28 3d 3e 20 eck-ec expr (=>
23d0: 65 71 75 61 6c 29 20 65 78 70 65 63 74 65 64 20 equal) expected
23e0: 28 61 72 67 20 2e 2e 2e 29 29 0a 20 20 20 20 20 (arg ...)).
23f0: 28 63 68 65 63 6b 2d 65 63 3a 6d 61 6b 65 20 28 (check-ec:make (
2400: 6e 65 73 74 65 64 29 20 65 78 70 72 20 28 3d 3e nested) expr (=>
2410: 20 65 71 75 61 6c 29 20 65 78 70 65 63 74 65 64 equal) expected
2420: 20 28 61 72 67 20 2e 2e 2e 29 29 29 0a 0a 20 20 (arg ...)))..
2430: 20 20 28 28 63 68 65 63 6b 2d 65 63 20 71 75 61 ((check-ec qua
2440: 6c 69 66 69 65 72 73 20 65 78 70 72 20 3d 3e 20 lifiers expr =>
2450: 65 78 70 65 63 74 65 64 29 0a 20 20 20 20 20 28 expected). (
2460: 63 68 65 63 6b 2d 65 63 3a 6d 61 6b 65 20 71 75 check-ec:make qu
2470: 61 6c 69 66 69 65 72 73 20 65 78 70 72 20 28 3d alifiers expr (=
2480: 3e 20 65 71 75 61 6c 3f 29 20 65 78 70 65 63 74 > equal?) expect
2490: 65 64 20 28 29 29 29 0a 20 20 20 20 28 28 63 68 ed ())). ((ch
24a0: 65 63 6b 2d 65 63 20 71 75 61 6c 69 66 69 65 72 eck-ec qualifier
24b0: 73 20 65 78 70 72 20 28 3d 3e 20 65 71 75 61 6c s expr (=> equal
24c0: 29 20 65 78 70 65 63 74 65 64 29 0a 20 20 20 20 ) expected).
24d0: 20 28 63 68 65 63 6b 2d 65 63 3a 6d 61 6b 65 20 (check-ec:make
24e0: 71 75 61 6c 69 66 69 65 72 73 20 65 78 70 72 20 qualifiers expr
24f0: 28 3d 3e 20 65 71 75 61 6c 29 20 65 78 70 65 63 (=> equal) expec
2500: 74 65 64 20 28 29 29 29 0a 20 20 20 20 28 28 63 ted ())). ((c
2510: 68 65 63 6b 2d 65 63 20 71 75 61 6c 69 66 69 65 heck-ec qualifie
2520: 72 73 20 65 78 70 72 20 3d 3e 20 65 78 70 65 63 rs expr => expec
2530: 74 65 64 20 28 61 72 67 20 2e 2e 2e 29 29 0a 20 ted (arg ...)).
2540: 20 20 20 20 28 63 68 65 63 6b 2d 65 63 3a 6d 61 (check-ec:ma
2550: 6b 65 20 71 75 61 6c 69 66 69 65 72 73 20 65 78 ke qualifiers ex
2560: 70 72 20 28 3d 3e 20 65 71 75 61 6c 3f 29 20 65 pr (=> equal?) e
2570: 78 70 65 63 74 65 64 20 28 61 72 67 20 2e 2e 2e xpected (arg ...
2580: 29 29 29 0a 20 20 20 20 28 28 63 68 65 63 6b 2d ))). ((check-
2590: 65 63 20 71 75 61 6c 69 66 69 65 72 73 20 65 78 ec qualifiers ex
25a0: 70 72 20 28 3d 3e 20 65 71 75 61 6c 29 20 65 78 pr (=> equal) ex
25b0: 70 65 63 74 65 64 20 28 61 72 67 20 2e 2e 2e 29 pected (arg ...)
25c0: 29 0a 20 20 20 20 20 28 63 68 65 63 6b 2d 65 63 ). (check-ec
25d0: 3a 6d 61 6b 65 20 71 75 61 6c 69 66 69 65 72 73 :make qualifiers
25e0: 20 65 78 70 72 20 28 3d 3e 20 65 71 75 61 6c 29 expr (=> equal)
25f0: 20 65 78 70 65 63 74 65 64 20 28 61 72 67 20 2e expected (arg .
2600: 2e 2e 29 29 29 0a 0a 20 20 20 20 28 28 63 68 65 ..))).. ((che
2610: 63 6b 2d 65 63 20 28 6e 65 73 74 65 64 20 71 31 ck-ec (nested q1
2620: 20 2e 2e 2e 29 20 71 20 65 74 63 20 2e 2e 2e 29 ...) q etc ...)
2630: 0a 20 20 20 20 20 28 63 68 65 63 6b 2d 65 63 20 . (check-ec
2640: 28 6e 65 73 74 65 64 20 71 31 20 2e 2e 2e 20 71 (nested q1 ... q
2650: 29 20 65 74 63 20 2e 2e 2e 29 29 0a 20 20 20 20 ) etc ...)).
2660: 28 28 63 68 65 63 6b 2d 65 63 20 71 31 20 71 32 ((check-ec q1 q2
2670: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 74 63 etc
2680: 20 2e 2e 2e 29 0a 20 20 20 20 20 28 63 68 65 63 ...). (chec
2690: 6b 2d 65 63 20 28 6e 65 73 74 65 64 20 71 31 20 k-ec (nested q1
26a0: 71 32 29 20 20 20 20 65 74 63 20 2e 2e 2e 29 29 q2) etc ...))
26b0: 29 29 0a )).