Artifact 9a5282dbe49ba5bb217e5724ff4906c8b3b9a03b:
- File runs-launch-loop-test.scm — part of check-in [051ff9ebd0] at 2013-04-30 20:55:40 on branch refactor — Capturing illustration of run launch loop (user: matt size: 1498) [more...]
0000: 28 75 73 65 20 73 72 66 69 2d 36 39 29 0a 0a 28 (use srfi-69)..( 0010: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 define (runs:que 0020: 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 ue-next-hed tal 0030: 72 65 67 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 reg n regful). 0040: 28 69 66 20 72 65 67 66 75 6c 0a 20 20 20 20 20 (if regful. 0050: 20 28 63 61 72 20 72 65 67 29 0a 20 20 20 20 20 (car reg). 0060: 20 28 63 61 72 20 74 61 6c 29 29 29 0a 0a 28 64 (car tal)))..(d 0070: 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 efine (runs:queu 0080: 65 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 e-next-tal tal r 0090: 65 67 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 eg n regful). ( 00a0: 69 66 20 72 65 67 66 75 6c 0a 20 20 20 20 20 20 if regful. 00b0: 74 61 6c 0a 20 20 20 20 20 20 28 6c 65 74 20 28 tal. (let ( 00c0: 28 6e 65 77 74 61 6c 20 28 63 64 72 20 74 61 6c (newtal (cdr tal 00d0: 29 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 )))..(if (null? 00e0: 6e 65 77 74 61 6c 29 0a 09 20 20 20 20 72 65 67 newtal).. reg 00f0: 0a 09 20 20 20 20 6e 65 77 74 61 6c 0a 09 20 20 .. newtal.. 0100: 20 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))..(define 0110: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next 0120: 2d 72 65 67 20 74 61 6c 20 72 65 67 20 6e 20 72 -reg tal reg n r 0130: 65 67 66 75 6c 29 0a 20 20 28 69 66 20 72 65 67 egful). (if reg 0140: 66 75 6c 0a 20 20 20 20 20 20 28 63 64 72 20 72 ful. (cdr r 0150: 65 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 eg). (if (e 0160: 71 3f 20 28 6c 65 6e 67 74 68 20 74 61 6c 29 20 q? (length tal) 0170: 31 29 0a 09 20 20 27 28 29 0a 09 20 20 72 65 67 1).. '().. reg 0180: 29 29 29 0a 0a 28 75 73 65 20 74 72 61 63 65 29 )))..(use trace) 0190: 0a 28 74 72 61 63 65 20 72 75 6e 73 3a 71 75 65 .(trace runs:que 01a0: 75 65 2d 6e 65 78 74 2d 68 65 64 0a 20 20 20 20 ue-next-hed. 01b0: 20 20 20 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 runs:queue-ne 01c0: 78 74 2d 74 61 6c 0a 20 20 20 20 20 20 20 72 75 xt-tal. ru 01d0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 ns:queue-next-re 01e0: 67 29 0a 0a 0a 28 64 65 66 69 6e 65 20 74 65 73 g)...(define tes 01f0: 74 73 20 27 28 31 20 32 20 33 20 34 20 35 20 36 ts '(1 2 3 4 5 6 0200: 20 37 20 38 20 39 20 31 30 20 31 31 20 31 32 20 7 8 9 10 11 12 0210: 31 33 20 31 34 20 31 35 20 31 36 20 31 37 20 31 13 14 15 16 17 1 0220: 38 20 31 39 20 32 30 29 29 0a 0a 28 64 65 66 69 8 19 20))..(defi 0230: 6e 65 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 ne test-registry 0240: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl 0250: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 6e 20 33 e))..(define n 3 0260: 29 0a 0a 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 )..(let loop ((h 0270: 65 64 20 20 20 28 63 61 72 20 74 65 73 74 73 29 ed (car tests) 0280: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 74 61 ). (ta 0290: 6c 20 20 20 28 63 64 72 20 74 65 73 74 73 29 29 l (cdr tests)) 02a0: 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 65 67 . (reg 02b0: 20 20 20 27 28 29 29 29 0a 20 20 28 6c 65 74 2a '())). (let* 02c0: 20 28 28 72 65 67 6c 65 6e 20 28 6c 65 6e 67 74 ((reglen (lengt 02d0: 68 20 72 65 67 29 29 0a 09 20 28 72 65 67 66 75 h reg)).. (regfu 02e0: 6c 20 28 3e 20 72 65 67 6c 65 6e 20 6e 29 29 29 l (> reglen n))) 02f0: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 68 65 64 . (print "hed 0300: 3d 22 20 68 65 64 20 22 2c 20 6c 65 6e 67 74 68 =" hed ", length 0310: 20 72 65 67 3d 22 20 28 6c 65 6e 67 74 68 20 72 reg=" (length r 0320: 65 67 29 20 22 2c 20 28 3e 20 6c 65 6e 72 65 67 eg) ", (> lenreg 0330: 20 6e 29 3d 22 20 28 3e 20 28 6c 65 6e 67 74 68 n)=" (> (length 0340: 20 72 65 67 29 20 6e 29 29 0a 20 20 20 20 28 6c reg) n)). (l 0350: 65 74 20 28 28 6e 65 77 74 61 6c 20 28 61 70 70 et ((newtal (app 0360: 65 6e 64 20 74 61 6c 20 28 6c 69 73 74 20 68 65 end tal (list he 0370: 64 29 29 29 29 20 3b 3b 20 75 73 65 64 20 69 66 d)))) ;; used if 0380: 20 77 65 20 61 72 65 20 6e 6f 74 20 64 6f 6e 65 we are not done 0390: 20 77 69 74 68 20 74 68 69 73 20 74 65 73 74 0a with this test. 03a0: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond. 03b0: 20 20 20 28 28 6e 6f 74 20 28 68 61 73 68 2d 74 ((not (hash-t 03c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default 03d0: 20 74 65 73 74 2d 72 65 67 69 73 74 72 79 20 68 test-registry h 03e0: 65 64 20 23 66 29 29 0a 09 28 68 61 73 68 2d 74 ed #f))..(hash-t 03f0: 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 able-set! test-r 0400: 65 67 69 73 74 72 79 20 68 65 64 20 23 74 29 0a egistry hed #t). 0410: 09 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 .(print "Registe 0420: 72 69 6e 67 20 23 22 20 68 65 64 29 0a 09 28 69 ring #" hed)..(i 0430: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta 0440: 6c 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c l)). (l 0450: 6f 6f 70 20 28 72 75 6e 73 3a 71 75 65 75 65 2d oop (runs:queue- 0460: 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 next-hed tal reg 0470: 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 20 20 20 n regful). 0480: 20 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 (runs 0490: 3a 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 :queue-next-tal 04a0: 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c tal reg n regful 04b0: 29 0a 09 09 28 6c 65 74 20 28 28 6e 65 77 6c 20 )...(let ((newl 04c0: 28 61 70 70 65 6e 64 20 72 65 67 20 28 6c 69 73 (append reg (lis 04d0: 74 20 68 65 64 29 29 29 29 0a 09 09 20 20 28 69 t hed))))... (i 04e0: 66 20 72 65 67 66 75 6c 0a 09 09 20 20 20 20 20 f regful... 04f0: 20 28 63 64 72 20 6e 65 77 6c 29 0a 09 09 20 20 (cdr newl)... 0500: 20 20 20 20 6e 65 77 6c 29 29 29 29 29 0a 20 20 newl))))). 0510: 20 20 20 20 20 28 65 6c 73 65 0a 09 28 70 72 69 (else..(pri 0520: 6e 74 20 22 52 75 6e 6e 69 6e 67 20 23 22 20 68 nt "Running #" h 0530: 65 64 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 6e ed)..(if (not (n 0540: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 20 20 20 20 ull? tal)).. 0550: 28 6c 6f 6f 70 20 28 72 75 6e 73 3a 71 75 65 75 (loop (runs:queu 0560: 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 72 e-next-hed tal r 0570: 65 67 20 6e 20 72 65 67 66 75 6c 29 0a 09 09 20 eg n regful)... 0580: 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 (runs:queue-nex 0590: 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 6e 20 t-tal tal reg n 05a0: 72 65 67 66 75 6c 29 0a 09 09 20 20 28 72 75 6e regful)... (run 05b0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg 05c0: 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 tal reg n regfu 05d0: 6c 29 29 29 29 29 29 29 29 0a l)))))))).