Artifact
e6dc11200a22186c255c4027fe7f2b2023fd5f3b:
0000: 28 75 73 65 20 73 72 66 69 2d 31 38 29 0a 0a 0a (use srfi-18)...
0010: 3b 3b 20 77 72 61 70 20 61 20 70 72 6f 63 20 77 ;; wrap a proc w
0020: 69 74 68 20 61 20 6d 75 74 65 78 20 73 6f 20 74 ith a mutex so t
0030: 68 61 74 20 74 77 6f 20 74 68 72 65 61 64 73 20 hat two threads
0040: 6d 61 79 20 6e 6f 74 20 63 61 6c 6c 20 70 72 6f may not call pro
0050: 63 20 73 69 6d 75 6c 74 61 6e 65 6f 75 73 6c 79 c simultaneously
0060: 2e 0a 3b 3b 20 77 69 6c 6c 20 63 61 74 63 68 20 ..;; will catch
0070: 65 78 63 65 70 74 69 6f 6e 73 20 74 6f 20 65 6e exceptions to en
0080: 73 75 72 65 20 6d 75 74 65 78 20 69 73 20 75 6e sure mutex is un
0090: 6c 6f 63 6b 65 64 20 65 76 65 6e 20 69 66 20 65 locked even if e
00a0: 78 63 65 70 74 69 6f 6e 20 69 73 20 74 68 72 6f xception is thro
00b0: 77 6e 2e 0a 3b 3b 20 77 69 6c 6c 20 67 65 6e 65 wn..;; will gene
00c0: 72 61 74 65 20 61 20 75 6e 69 71 75 65 20 6d 75 rate a unique mu
00d0: 74 65 78 20 66 6f 72 20 70 72 6f 63 20 75 6e 6c tex for proc unl
00e0: 65 73 73 20 6f 6e 65 20 69 73 20 73 70 65 63 69 ess one is speci
00f0: 66 69 65 64 20 77 69 74 68 20 63 61 6e 6e 65 64 fied with canned
0100: 2d 6d 75 74 65 78 3a 20 6f 70 74 69 6f 6e 0a 3b -mutex: option.;
0110: 3b 0a 3b 3b 20 65 78 61 6d 70 6c 65 20 31 3a 20 ;.;; example 1:
0120: 28 64 65 66 69 6e 65 20 74 68 72 65 61 64 2d 73 (define thread-s
0130: 61 66 65 2d 2b 20 28 6d 61 6b 65 2d 73 79 6e 63 afe-+ (make-sync
0140: 68 72 6f 6e 69 7a 65 64 2d 70 72 6f 63 20 2b 29 hronized-proc +)
0150: 29 0a 3b 3b 20 65 78 61 6d 70 6c 65 20 32 3a 20 ).;; example 2:
0160: 28 64 65 66 69 6e 65 20 74 68 72 65 61 64 2d 73 (define thread-s
0170: 61 66 65 2d 70 6c 75 73 0a 3b 3b 20 20 20 20 20 afe-plus.;;
0180: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
0190: 73 79 6e 63 68 72 6f 6e 69 7a 65 64 2d 70 72 6f synchronized-pro
01a0: 63 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 c.;;
01b0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 78 (lambda (x
01c0: 20 79 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 y).;;
01d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 78 (+ x
01e0: 20 79 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y))))..(define
01f0: 28 6d 61 6b 65 2d 73 79 6e 63 68 72 6f 6e 69 7a (make-synchroniz
0200: 65 64 2d 70 72 6f 63 20 70 72 6f 63 0a 20 20 20 ed-proc proc.
0210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0220: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 21 6b #!k
0230: 65 79 20 28 63 61 6e 6e 65 64 2d 6d 75 74 65 78 ey (canned-mutex
0240: 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 #f)). (let* ((
0250: 67 75 61 72 64 2d 6d 75 74 65 78 20 28 69 66 20 guard-mutex (if
0260: 63 61 6e 6e 65 64 2d 6d 75 74 65 78 20 63 61 6e canned-mutex can
0270: 6e 65 64 2d 6d 75 74 65 78 20 28 6d 61 6b 65 2d ned-mutex (make-
0280: 6d 75 74 65 78 29 29 29 0a 20 20 20 20 20 20 20 mutex))).
0290: 20 20 28 67 75 61 72 64 65 64 2d 70 72 6f 63 20 (guarded-proc
02a0: 3b 3b 20 77 65 20 61 72 65 20 67 75 61 72 64 69 ;; we are guardi
02b0: 6e 67 20 74 68 65 20 74 68 75 6e 6b 20 61 67 61 ng the thunk aga
02c0: 69 6e 73 74 20 65 78 63 65 70 74 69 6f 6e 73 2e inst exceptions.
02d0: 20 20 57 65 20 77 69 6c 6c 20 72 65 63 6f 72 64 We will record
02e0: 20 77 68 65 74 68 65 72 20 72 65 73 75 6c 74 20 whether result
02f0: 6f 66 20 65 76 61 6c 75 61 74 69 6f 6e 20 69 73 of evaluation is
0300: 20 61 6e 20 65 78 63 65 70 74 69 6f 6e 20 6f 72 an exception or
0310: 20 61 20 72 65 67 75 6c 61 72 20 72 65 73 75 6c a regular resul
0320: 74 2e 0a 20 20 20 20 20 20 20 20 20 20 28 6c 61 t.. (la
0330: 6d 62 64 61 20 61 72 67 73 0a 20 20 20 20 20 20 mbda args.
0340: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 (mutex-loc
0350: 6b 21 20 67 75 61 72 64 2d 6d 75 74 65 78 29 0a k! guard-mutex).
0360: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
0370: 2a 20 28 28 45 58 43 45 50 54 49 4f 4e 20 28 67 * ((EXCEPTION (g
0380: 65 6e 73 79 6d 29 29 20 3b 3b 20 75 73 69 6e 67 ensym)) ;; using
0390: 20 67 65 6e 73 79 6d 20 74 6f 20 61 76 6f 69 64 gensym to avoid
03a0: 20 70 6f 74 65 6e 74 69 61 6c 20 63 6f 6c 6c 69 potential colli
03b0: 73 69 6f 6e 20 77 69 74 68 20 61 20 70 72 6f 63 sion with a proc
03c0: 20 74 68 61 74 20 72 65 74 75 72 6e 73 20 61 20 that returns a
03d0: 70 61 69 72 20 68 61 76 69 6e 67 20 74 68 65 20 pair having the
03e0: 66 69 72 73 74 20 65 6c 65 6d 65 6e 74 20 62 65 first element be
03f0: 20 6f 75 72 20 66 6c 61 67 2e 20 20 67 65 6e 73 our flag. gens
0400: 79 6d 20 67 75 61 72 61 6e 74 65 65 73 20 74 68 ym guarantees th
0410: 65 20 73 79 6d 62 6f 6c 20 69 73 20 75 6e 69 71 e symbol is uniq
0420: 75 65 2e 0a 20 20 20 20 20 20 20 20 20 20 20 20 ue..
0430: 20 20 20 20 20 20 20 28 72 65 73 0a 20 20 20 20 (res.
0440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0450: 28 63 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a (condition-case.
0460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0470: 20 20 20 20 20 28 61 70 70 6c 79 20 70 72 6f 63 (apply proc
0480: 20 61 72 67 73 29 20 3b 3b 20 74 68 69 73 20 69 args) ;; this i
0490: 73 20 77 68 61 74 20 77 65 20 61 72 65 20 67 75 s what we are gu
04a0: 61 72 64 69 6e 67 20 74 68 65 20 65 78 65 63 75 arding the execu
04b0: 74 69 6f 6e 20 6f 66 0a 20 20 20 20 20 20 20 20 tion of.
04c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 5b 78 20 [x
04d0: 28 29 20 28 63 6f 6e 73 20 45 58 43 45 50 54 49 () (cons EXCEPTI
04e0: 4f 4e 20 78 29 5d 0a 20 20 20 20 20 20 20 20 20 ON x)].
04f0: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 29 0a ))).
0500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
0510: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 67 75 61 utex-unlock! gua
0520: 72 64 2d 6d 75 74 65 78 29 0a 20 20 20 20 20 20 rd-mutex).
0530: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
0540: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
0550: 6e 64 20 28 70 61 69 72 3f 20 72 65 73 29 20 28 nd (pair? res) (
0560: 65 71 3f 20 28 63 61 72 20 72 65 73 29 20 45 58 eq? (car res) EX
0570: 43 45 50 54 49 4f 4e 29 29 0a 20 20 20 20 20 20 CEPTION)).
0580: 20 20 20 20 20 20 20 20 20 20 28 72 61 69 73 65 (raise
0590: 20 28 63 64 72 20 72 65 73 29 29 29 0a 20 20 20 (cdr res))).
05a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
05b0: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
05c0: 20 20 72 65 73 29 29 29 29 29 29 0a 20 20 20 20 res)))))).
05d0: 67 75 61 72 64 65 64 2d 70 72 6f 63 29 29 0a 0a guarded-proc))..
05e0: 0a 3b 3b 20 72 65 74 72 79 20 61 6e 20 6f 70 65 .;; retry an ope
05f0: 72 61 74 69 6f 6e 20 28 64 65 70 65 6e 64 73 20 ration (depends
0600: 6f 6e 20 73 72 66 69 2d 31 38 29 0a 3b 3b 20 3d on srfi-18).;; =
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 0a 3b 3b 20 69 64 65 61 20 68 65 72 65 20 69 =.;; idea here i
0630: 73 20 74 6f 20 61 76 6f 69 64 20 73 70 65 6e 64 s to avoid spend
0640: 69 6e 67 20 74 69 6d 65 20 6f 6e 20 63 6f 64 69 ing time on codi
0650: 6e 67 20 72 65 74 72 79 69 6e 67 20 73 6f 6d 65 ng retrying some
0660: 74 68 69 6e 67 2e 20 20 54 72 79 69 6e 67 20 74 thing. Trying t
0670: 6f 20 62 65 20 67 65 6e 65 72 69 63 20 68 65 72 o be generic her
0680: 65 2e 0a 3b 3b 0a 3b 3b 20 45 78 63 65 70 74 69 e..;;.;; Excepti
0690: 6f 6e 20 68 61 6e 64 6c 69 6e 67 3a 0a 3b 3b 20 on handling:.;;
06a0: 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d 2d ----------------
06b0: 2d 2d 2d 0a 3b 3b 20 69 66 20 65 76 61 6c 75 61 ---.;; if evalua
06c0: 74 69 6e 67 20 74 68 65 20 74 68 75 6e 6b 20 72 ting the thunk r
06d0: 65 73 75 6c 74 73 20 69 6e 20 65 78 63 65 70 74 esults in except
06e0: 69 6f 6e 2c 20 69 74 20 77 69 6c 6c 20 62 65 20 ion, it will be
06f0: 72 65 74 72 69 65 64 2e 0a 3b 3b 20 6f 6e 20 6c retried..;; on l
0700: 61 73 74 20 74 72 79 2c 20 69 66 20 66 69 6e 61 ast try, if fina
0710: 6c 2d 66 61 69 6c 75 72 65 2d 72 65 74 75 72 6e l-failure-return
0720: 73 2d 61 63 74 75 61 6c 20 69 73 20 74 72 75 65 s-actual is true
0730: 2c 20 74 68 65 20 65 78 63 65 70 74 69 6f 6e 20 , the exception
0740: 77 69 6c 6c 20 62 65 20 72 65 2d 74 68 72 6f 77 will be re-throw
0750: 6e 20 74 6f 20 63 61 6c 6c 65 72 2e 0a 3b 3b 0a n to caller..;;.
0760: 3b 3b 20 6c 6f 6f 6b 20 61 74 20 6f 70 74 69 6f ;; look at optio
0770: 6e 73 20 62 65 6c 6f 77 20 23 21 6b 65 79 20 74 ns below #!key t
0780: 6f 20 73 65 65 20 68 6f 77 20 74 6f 20 63 6f 6e o see how to con
0790: 66 69 67 75 72 65 20 62 65 68 61 76 69 6f 72 0a figure behavior.
07a0: 3b 3b 0a 3b 3b 0a 0a 28 64 65 66 69 6e 65 20 28 ;;.;;..(define (
07b0: 72 65 74 72 79 2d 74 68 75 6e 6b 0a 20 20 20 20 retry-thunk.
07c0: 20 20 20 20 20 74 68 65 2d 74 68 75 6e 6b 0a 20 the-thunk.
07d0: 20 20 20 20 20 20 20 20 23 21 6b 65 79 20 3b 3b #!key ;;
07e0: 3b 3b 20 6f 70 74 69 6f 6e 73 20 62 65 6c 6f 77 ;; options below
07f0: 0a 20 20 20 20 20 20 20 20 20 28 61 63 63 65 70 . (accep
0800: 74 2d 72 65 73 75 6c 74 3f 20 20 20 28 6c 61 6d t-result? (lam
0810: 62 64 61 20 28 78 29 20 78 29 29 20 3b 3b 20 72 bda (x) x)) ;; r
0820: 65 74 72 79 20 69 66 20 70 72 65 64 69 63 61 74 etry if predicat
0830: 65 20 61 70 70 6c 69 65 64 20 74 6f 20 74 68 75 e applied to thu
0840: 6e 6b 27 73 20 72 65 73 75 6c 74 20 69 73 20 66 nk's result is f
0850: 61 6c 73 65 20 0a 20 20 20 20 20 20 20 20 20 28 alse . (
0860: 72 65 74 72 69 65 73 20 20 20 20 20 20 20 20 20 retries
0870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 34 29 4)
0880: 20 3b 3b 20 68 6f 77 20 6d 61 6e 79 20 74 72 69 ;; how many tri
0890: 65 73 0a 20 20 20 20 20 20 20 20 20 28 66 61 69 es. (fai
08a0: 6c 75 72 65 2d 76 61 6c 75 65 20 20 20 20 20 20 lure-value
08b0: 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b #f) ;;
08c0: 20 72 65 74 75 72 6e 20 74 68 69 73 20 6f 6e 20 return this on
08d0: 66 69 6e 61 6c 20 66 61 69 6c 75 72 65 2c 20 75 final failure, u
08e0: 6e 6c 65 73 73 20 66 6f 6c 6c 6f 77 69 6e 67 20 nless following
08f0: 6f 70 74 69 6f 6e 20 69 73 20 65 6e 61 62 6c 65 option is enable
0900: 64 3a 0a 20 20 20 20 20 20 20 20 20 28 66 69 6e d:. (fin
0910: 61 6c 2d 66 61 69 6c 75 72 65 2d 72 65 74 75 72 al-failure-retur
0920: 6e 73 2d 61 63 74 75 61 6c 20 23 66 29 20 3b 3b ns-actual #f) ;;
0930: 20 6f 6e 20 66 61 69 6c 75 72 65 2c 20 6f 6e 20 on failure, on
0940: 74 68 65 20 6c 61 73 74 20 74 72 79 2c 20 6a 75 the last try, ju
0950: 73 74 20 72 65 74 75 72 6e 20 74 68 65 20 72 65 st return the re
0960: 73 75 6c 74 2c 20 6e 6f 74 20 66 61 69 6c 75 72 sult, not failur
0970: 65 2d 76 61 6c 75 65 0a 0a 20 20 20 20 20 20 20 e-value..
0980: 20 20 28 72 65 74 72 79 2d 64 65 6c 61 79 20 20 (retry-delay
0990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 30 0
09a0: 2e 31 29 20 3b 3b 20 64 65 6c 61 79 20 62 65 74 .1) ;; delay bet
09b0: 77 65 65 6e 20 74 72 69 65 73 0a 20 20 20 20 20 ween tries.
09c0: 20 20 20 20 28 62 61 63 6b 2d 6f 66 66 2d 66 61 (back-off-fa
09d0: 63 74 6f 72 20 20 20 20 20 20 20 20 20 20 20 20 ctor
09e0: 20 20 20 31 29 20 3b 3b 20 6d 75 6c 74 69 70 6c 1) ;; multipl
09f0: 79 20 72 65 74 72 79 2d 64 65 6c 61 79 20 62 79 y retry-delay by
0a00: 20 74 68 69 73 20 66 61 63 74 6f 72 20 6f 6e 20 this factor on
0a10: 72 65 74 72 79 0a 20 20 20 20 20 20 20 20 20 28 retry. (
0a20: 72 61 6e 64 6f 6d 2d 64 65 6c 61 79 20 20 20 20 random-delay
0a30: 20 20 20 20 20 20 20 20 20 20 20 20 30 2e 31 29 0.1)
0a40: 20 3b 3b 20 61 64 64 20 61 20 72 61 6e 64 6f 6d ;; add a random
0a50: 20 70 6f 72 74 69 6f 6e 20 6f 66 20 74 68 69 73 portion of this
0a60: 20 76 61 6c 75 65 20 74 6f 20 77 61 69 74 0a 0a value to wait..
0a70: 20 20 20 20 20 20 20 20 20 28 63 68 61 74 74 79 (chatty
0a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a90: 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 70 72 #f) ;; pr
0aa0: 69 6e 74 20 73 74 61 74 75 73 20 61 73 20 77 65 int status as we
0ab0: 20 67 6f 2c 20 66 6f 72 20 64 65 62 75 67 67 69 go, for debuggi
0ac0: 6e 67 2e 0a 20 20 20 20 20 20 20 20 20 29 0a 20 ng.. ).
0ad0: 20 0a 20 20 28 77 68 65 6e 20 63 68 61 74 74 79 . (when chatty
0ae0: 20 28 70 72 69 6e 74 29 20 28 70 72 69 6e 74 20 (print) (print
0af0: 22 45 6e 74 65 72 65 64 20 72 65 74 72 79 2d 74 "Entered retry-t
0b00: 68 75 6e 6b 22 29 20 28 70 72 69 6e 74 20 22 2d hunk") (print "-
0b10: 3d 2d 3d 2d 3d 2d 3d 2d 3d 2d 22 29 29 0a 20 20 =-=-=-=-=-")).
0b20: 28 6c 65 74 2a 20 28 28 67 75 61 72 64 65 64 2d (let* ((guarded-
0b30: 74 68 75 6e 6b 20 3b 3b 20 77 65 20 61 72 65 20 thunk ;; we are
0b40: 67 75 61 72 64 69 6e 67 20 74 68 65 20 74 68 75 guarding the thu
0b50: 6e 6b 20 61 67 61 69 6e 73 74 20 65 78 63 65 70 nk against excep
0b60: 74 69 6f 6e 73 2e 20 20 57 65 20 77 69 6c 6c 20 tions. We will
0b70: 72 65 63 6f 72 64 20 77 68 65 74 68 65 72 20 72 record whether r
0b80: 65 73 75 6c 74 20 6f 66 20 65 76 61 6c 75 61 74 esult of evaluat
0b90: 69 6f 6e 20 69 73 20 61 6e 20 65 78 63 65 70 74 ion is an except
0ba0: 69 6f 6e 20 6f 72 20 61 20 72 65 67 75 6c 61 72 ion or a regular
0bb0: 20 72 65 73 75 6c 74 2e 0a 20 20 20 20 20 20 20 result..
0bc0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
0bd0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
0be0: 28 45 58 43 45 50 54 49 4f 4e 20 28 67 65 6e 73 (EXCEPTION (gens
0bf0: 79 6d 29 29 20 3b 3b 20 75 73 69 6e 67 20 67 65 ym)) ;; using ge
0c00: 6e 73 79 6d 20 74 6f 20 61 76 6f 69 64 20 70 6f nsym to avoid po
0c10: 74 65 6e 74 69 61 6c 20 63 6f 6c 6c 69 73 69 6f tential collisio
0c20: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
0c30: 20 20 20 20 28 72 65 73 0a 20 20 20 20 20 20 20 (res.
0c40: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
0c50: 64 69 74 69 6f 6e 2d 63 61 73 65 0a 20 20 20 20 dition-case.
0c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c70: 28 74 68 65 2d 74 68 75 6e 6b 29 20 3b 3b 20 74 (the-thunk) ;; t
0c80: 68 69 73 20 69 73 20 77 68 61 74 20 77 65 20 61 his is what we a
0c90: 72 65 20 67 75 61 72 64 69 6e 67 20 74 68 65 20 re guarding the
0ca0: 65 78 65 63 75 74 69 6f 6e 20 6f 66 0a 20 20 20 execution of.
0cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0cc0: 20 5b 78 20 28 29 20 28 63 6f 6e 73 20 45 58 43 [x () (cons EXC
0cd0: 45 50 54 49 4f 4e 20 78 29 5d 0a 20 20 20 20 20 EPTION x)].
0ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 )
0cf0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0d00: 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 (cond.
0d10: 20 20 20 20 28 28 61 6e 64 20 28 70 61 69 72 3f ((and (pair?
0d20: 20 72 65 73 29 20 28 65 71 3f 20 28 63 61 72 20 res) (eq? (car
0d30: 72 65 73 29 20 45 58 43 45 50 54 49 4f 4e 29 29 res) EXCEPTION))
0d40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0d50: 28 69 66 20 63 68 61 74 74 79 0a 20 20 20 20 20 (if chatty.
0d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
0d70: 72 69 6e 74 20 22 20 2d 20 74 68 65 2d 74 68 75 rint " - the-thu
0d80: 6e 6b 20 74 68 72 65 77 20 65 78 63 65 70 74 69 nk threw excepti
0d90: 6f 6e 20 3e 22 28 63 64 72 20 72 65 73 29 22 3c on >"(cdr res)"<
0da0: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
0db0: 20 20 20 28 63 6f 6e 73 20 27 65 78 63 65 70 74 (cons 'except
0dc0: 69 6f 6e 20 28 63 64 72 20 72 65 73 29 29 29 0a ion (cdr res))).
0dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0de0: 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 else.
0df0: 20 20 20 20 20 28 69 66 20 63 68 61 74 74 79 0a (if chatty.
0e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e10: 20 20 20 20 28 70 72 69 6e 74 20 22 20 2d 20 74 (print " - t
0e20: 68 65 2d 74 68 75 6e 6b 20 72 65 74 75 72 6e 65 he-thunk returne
0e30: 64 20 72 65 73 75 6c 74 20 3e 22 72 65 73 22 3c d result >"res"<
0e40: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
0e50: 20 20 20 20 28 63 6f 6e 73 20 27 72 65 67 75 6c (cons 'regul
0e60: 61 72 2d 72 65 73 75 6c 74 20 72 65 73 29 29 29 ar-result res)))
0e70: 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 28 6c )))). . (l
0e80: 65 74 20 6c 6f 6f 70 20 28 28 67 75 61 72 64 65 et loop ((guarde
0e90: 64 2d 72 65 73 20 28 67 75 61 72 64 65 64 2d 74 d-res (guarded-t
0ea0: 68 75 6e 6b 29 29 0a 20 20 20 20 20 20 20 20 20 hunk)).
0eb0: 20 20 20 20 20 20 28 72 65 74 72 69 65 73 2d 6c (retries-l
0ec0: 65 66 74 20 72 65 74 72 69 65 73 29 0a 20 20 20 eft retries).
0ed0: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 61 69 (fai
0ee0: 6c 2d 77 61 69 74 20 72 65 74 72 79 2d 64 65 6c l-wait retry-del
0ef0: 61 79 29 29 0a 20 20 20 20 20 20 28 69 66 20 63 ay)). (if c
0f00: 68 61 74 74 79 20 28 70 72 69 6e 74 20 22 20 20 hatty (print "
0f10: 20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 22 29 29 0a 20 ==========")).
0f20: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 77 61 69 (let* ((wai
0f30: 74 2d 74 69 6d 65 20 28 2b 20 66 61 69 6c 2d 77 t-time (+ fail-w
0f40: 61 69 74 20 28 2b 20 28 2a 20 66 61 69 6c 2d 77 ait (+ (* fail-w
0f50: 61 69 74 20 62 61 63 6b 2d 6f 66 66 2d 66 61 63 ait back-off-fac
0f60: 74 6f 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 tor).
0f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 2a 20 (*
0f90: 72 61 6e 64 6f 6d 2d 64 65 6c 61 79 0a 20 20 20 random-delay.
0fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0fc0: 20 20 20 20 20 20 20 20 28 2f 20 28 72 61 6e 64 (/ (rand
0fd0: 6f 6d 20 31 30 32 34 29 20 31 30 32 34 29 20 29 om 1024) 1024) )
0fe0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
0ff0: 20 28 72 65 73 2d 74 79 70 65 20 28 63 61 72 20 (res-type (car
1000: 67 75 61 72 64 65 64 2d 72 65 73 29 29 0a 20 20 guarded-res)).
1010: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 2d (res-
1020: 76 61 6c 75 65 20 28 63 64 72 20 67 75 61 72 64 value (cdr guard
1030: 65 64 2d 72 65 73 29 29 29 0a 20 20 20 20 20 20 ed-res))).
1040: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
1050: 20 28 28 61 6e 64 20 28 65 71 3f 20 72 65 73 2d ((and (eq? res-
1060: 74 79 70 65 20 27 72 65 67 75 6c 61 72 2d 72 65 type 'regular-re
1070: 73 75 6c 74 29 20 28 61 63 63 65 70 74 2d 72 65 sult) (accept-re
1080: 73 75 6c 74 3f 20 72 65 73 2d 76 61 6c 75 65 29 sult? res-value)
1090: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
10a0: 20 20 20 20 20 28 69 66 20 63 68 61 74 74 79 20 (if chatty
10b0: 28 70 72 69 6e 74 20 22 20 2b 20 72 65 74 75 72 (print " + retur
10c0: 6e 20 72 65 73 75 6c 74 20 74 68 61 74 20 73 61 n result that sa
10d0: 74 69 73 66 69 65 64 20 61 63 63 65 70 74 2d 72 tisfied accept-r
10e0: 65 73 75 6c 74 3f 20 3e 22 72 65 73 2d 76 61 6c esult? >"res-val
10f0: 75 65 22 3c 22 29 29 0a 20 20 20 20 20 20 20 20 ue"<")).
1100: 20 20 20 20 20 20 20 20 20 20 20 72 65 73 2d 76 res-v
1110: 61 6c 75 65 29 0a 0a 20 20 20 20 20 20 20 20 20 alue)..
1120: 28 28 3e 20 72 65 74 72 69 65 73 2d 6c 65 66 74 ((> retries-left
1130: 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 0). (i
1140: 66 20 63 68 61 74 74 79 20 28 70 72 69 6e 74 20 f chatty (print
1150: 22 20 2d 20 73 6c 65 65 70 20 22 77 61 69 74 2d " - sleep "wait-
1160: 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 time)).
1170: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
1180: 77 61 69 74 2d 74 69 6d 65 29 0a 20 20 20 20 20 wait-time).
1190: 20 20 20 20 20 28 69 66 20 63 68 61 74 74 79 20 (if chatty
11a0: 28 70 72 69 6e 74 20 22 20 2b 20 72 65 74 72 79 (print " + retry
11b0: 20 5b 22 72 65 74 72 69 65 73 2d 6c 65 66 74 22 ["retries-left"
11c0: 20 74 72 69 65 73 20 6c 65 66 74 5d 22 29 29 0a tries left]")).
11d0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
11e0: 28 67 75 61 72 64 65 64 2d 74 68 75 6e 6b 29 0a (guarded-thunk).
11f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1200: 28 73 75 62 31 20 72 65 74 72 69 65 73 2d 6c 65 (sub1 retries-le
1210: 66 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ft).
1220: 20 20 20 20 77 61 69 74 2d 74 69 6d 65 29 29 0a wait-time)).
1230: 20 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 .
1240: 20 20 20 28 28 65 71 3f 20 72 65 73 2d 74 79 70 ((eq? res-typ
1250: 65 20 27 72 65 67 75 6c 61 72 2d 72 65 73 75 6c e 'regular-resul
1260: 74 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 t). (if
1270: 20 66 69 6e 61 6c 2d 66 61 69 6c 75 72 65 2d 72 final-failure-r
1280: 65 74 75 72 6e 73 2d 61 63 74 75 61 6c 0a 20 20 eturns-actual.
1290: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
12a0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
12b0: 20 20 20 28 69 66 20 63 68 61 74 74 79 20 28 70 (if chatty (p
12c0: 72 69 6e 74 20 22 20 2b 20 6c 61 73 74 20 74 72 rint " + last tr
12d0: 79 20 66 61 69 6c 65 64 2d 20 72 65 74 75 72 6e y failed- return
12e0: 20 74 68 65 20 72 65 73 75 6c 74 20 3e 22 72 65 the result >"re
12f0: 73 2d 76 61 6c 75 65 22 3c 22 29 29 0a 20 20 20 s-value"<")).
1300: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 res
1310: 2d 76 61 6c 75 65 29 0a 20 20 20 20 20 20 20 20 -value).
1320: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
1330: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
1340: 20 63 68 61 74 74 79 20 28 70 72 69 6e 74 20 22 chatty (print "
1350: 20 2b 20 6c 61 73 74 20 74 72 79 20 66 61 69 6c + last try fail
1360: 65 64 2d 20 72 65 74 75 72 6e 20 63 61 6e 6e 65 ed- return canne
1370: 64 20 66 61 69 6c 75 72 65 20 76 61 6c 75 65 20 d failure value
1380: 3e 22 66 61 69 6c 75 72 65 2d 76 61 6c 75 65 22 >"failure-value"
1390: 3c 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 <")).
13a0: 20 20 20 66 61 69 6c 75 72 65 2d 76 61 6c 75 65 failure-value
13b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 0a 20 20 ))). .
13c0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 (else ;;
13d0: 6e 6f 20 72 65 74 72 69 65 73 20 6c 65 66 74 3b no retries left;
13e0: 20 72 65 73 75 6c 74 20 77 61 73 20 6e 6f 74 20 result was not
13f0: 61 63 63 65 70 74 65 64 20 61 6e 64 20 72 65 73 accepted and res
1400: 2d 74 79 70 65 20 63 61 6e 20 6f 6e 6c 79 20 62 -type can only b
1410: 65 20 27 65 78 63 65 70 74 69 6f 6e 0a 20 20 20 e 'exception.
1420: 20 20 20 20 20 20 20 28 69 66 20 66 69 6e 61 6c (if final
1430: 2d 66 61 69 6c 75 72 65 2d 72 65 74 75 72 6e 73 -failure-returns
1440: 2d 61 63 74 75 61 6c 20 0a 20 20 20 20 20 20 20 -actual .
1450: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
1460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
1470: 66 20 63 68 61 74 74 79 20 28 70 72 69 6e 74 20 f chatty (print
1480: 22 20 2b 20 6c 61 73 74 20 74 72 79 20 66 61 69 " + last try fai
1490: 6c 65 64 20 77 69 74 68 20 65 78 63 65 70 74 69 led with excepti
14a0: 6f 6e 2d 20 72 65 2d 74 68 72 6f 77 20 69 74 20 on- re-throw it
14b0: 3e 22 72 65 73 2d 76 61 6c 75 65 22 3c 22 29 29 >"res-value"<"))
14c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
14d0: 20 28 61 62 6f 72 74 20 72 65 73 2d 76 61 6c 75 (abort res-valu
14e0: 65 29 29 3b 20 72 65 2d 72 61 69 73 65 20 74 68 e)); re-raise th
14f0: 65 20 65 78 63 65 70 74 69 6f 6e 2e 20 54 4f 44 e exception. TOD
1500: 4f 3a 20 66 69 6e 64 20 61 20 77 61 79 20 66 6f O: find a way fo
1510: 72 20 63 61 6c 6c 2d 68 69 73 74 6f 72 79 20 74 r call-history t
1520: 6f 20 73 68 6f 77 20 61 73 20 74 68 6f 75 67 68 o show as though
1530: 20 66 72 6f 6d 20 65 6e 74 72 79 20 74 6f 20 74 from entry to t
1540: 68 69 73 20 66 75 6e 63 74 69 6f 6e 0a 20 20 20 his function.
1550: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
1560: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
1570: 20 20 28 69 66 20 63 68 61 74 74 79 20 28 70 72 (if chatty (pr
1580: 69 6e 74 20 22 20 2b 20 6c 61 73 74 20 74 72 79 int " + last try
1590: 20 66 61 69 6c 65 64 20 77 69 74 68 20 65 78 63 failed with exc
15a0: 65 70 74 69 6f 6e 2d 20 72 65 74 75 72 6e 20 63 eption- return c
15b0: 61 6e 6e 65 64 20 66 61 69 6c 75 72 65 20 76 61 anned failure va
15c0: 6c 75 65 20 3e 22 66 61 69 6c 75 72 65 2d 76 61 lue >"failure-va
15d0: 6c 75 65 22 3c 22 29 29 0a 20 20 20 20 20 20 20 lue"<")).
15e0: 20 20 20 20 20 20 20 20 20 66 61 69 6c 75 72 65 failure
15f0: 2d 76 61 6c 75 65 29 29 29 29 29 29 29 29 0a 0a -value))))))))..