Artifact 22874fa5ef06489f4b5de2442fda6b8c0e336b32:
- File srfi/s128/128.body2.scm — part of check-in [07be5132aa] at 2017-01-11 16:37:00 on branch trunk — added srfi 113 sets&bags, srfi 128 comparators (user: aldo size: 5541)
0000: 3b 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 43 ;;; Copyright (C 0010: 29 20 4a 6f 68 6e 20 43 6f 77 61 6e 20 28 32 30 ) John Cowan (20 0020: 31 35 29 2e 20 41 6c 6c 20 52 69 67 68 74 73 20 15). All Rights 0030: 52 65 73 65 72 76 65 64 2e 0a 3b 3b 3b 20 0a 3b Reserved..;;; .; 0040: 3b 3b 20 50 65 72 6d 69 73 73 69 6f 6e 20 69 73 ;; Permission is 0050: 20 68 65 72 65 62 79 20 67 72 61 6e 74 65 64 2c hereby granted, 0060: 20 66 72 65 65 20 6f 66 20 63 68 61 72 67 65 2c free of charge, 0070: 20 74 6f 20 61 6e 79 20 70 65 72 73 6f 6e 0a 3b to any person.; 0080: 3b 3b 20 6f 62 74 61 69 6e 69 6e 67 20 61 20 63 ;; obtaining a c 0090: 6f 70 79 20 6f 66 20 74 68 69 73 20 73 6f 66 74 opy of this soft 00a0: 77 61 72 65 20 61 6e 64 20 61 73 73 6f 63 69 61 ware and associa 00b0: 74 65 64 20 64 6f 63 75 6d 65 6e 74 61 74 69 6f ted documentatio 00c0: 6e 0a 3b 3b 3b 20 66 69 6c 65 73 20 28 74 68 65 n.;;; files (the 00d0: 20 22 53 6f 66 74 77 61 72 65 22 29 2c 20 74 6f "Software"), to 00e0: 20 64 65 61 6c 20 69 6e 20 74 68 65 20 53 6f 66 deal in the Sof 00f0: 74 77 61 72 65 20 77 69 74 68 6f 75 74 0a 3b 3b tware without.;; 0100: 3b 20 72 65 73 74 72 69 63 74 69 6f 6e 2c 20 69 ; restriction, i 0110: 6e 63 6c 75 64 69 6e 67 20 77 69 74 68 6f 75 74 ncluding without 0120: 20 6c 69 6d 69 74 61 74 69 6f 6e 20 74 68 65 20 limitation the 0130: 72 69 67 68 74 73 20 74 6f 20 75 73 65 2c 0a 3b rights to use,.; 0140: 3b 3b 20 63 6f 70 79 2c 20 6d 6f 64 69 66 79 2c ;; copy, modify, 0150: 20 6d 65 72 67 65 2c 20 70 75 62 6c 69 73 68 2c merge, publish, 0160: 20 64 69 73 74 72 69 62 75 74 65 2c 20 73 75 62 distribute, sub 0170: 6c 69 63 65 6e 73 65 2c 20 61 6e 64 2f 6f 72 0a license, and/or. 0180: 3b 3b 3b 20 73 65 6c 6c 20 63 6f 70 69 65 73 20 ;;; sell copies 0190: 6f 66 20 74 68 65 20 53 6f 66 74 77 61 72 65 2c of the Software, 01a0: 20 61 6e 64 20 74 6f 20 70 65 72 6d 69 74 20 70 and to permit p 01b0: 65 72 73 6f 6e 73 20 74 6f 20 77 68 6f 6d 20 74 ersons to whom t 01c0: 68 65 0a 3b 3b 3b 20 53 6f 66 74 77 61 72 65 20 he.;;; Software 01d0: 69 73 20 66 75 72 6e 69 73 68 65 64 20 74 6f 20 is furnished to 01e0: 64 6f 20 73 6f 2c 20 73 75 62 6a 65 63 74 20 74 do so, subject t 01f0: 6f 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 0a o the following. 0200: 3b 3b 3b 20 63 6f 6e 64 69 74 69 6f 6e 73 3a 0a ;;; conditions:. 0210: 3b 3b 3b 20 0a 3b 3b 3b 20 54 68 65 20 61 62 6f ;;; .;;; The abo 0220: 76 65 20 63 6f 70 79 72 69 67 68 74 20 6e 6f 74 ve copyright not 0230: 69 63 65 20 61 6e 64 20 74 68 69 73 20 70 65 72 ice and this per 0240: 6d 69 73 73 69 6f 6e 20 6e 6f 74 69 63 65 20 73 mission notice s 0250: 68 61 6c 6c 20 62 65 0a 3b 3b 3b 20 69 6e 63 6c hall be.;;; incl 0260: 75 64 65 64 20 69 6e 20 61 6c 6c 20 63 6f 70 69 uded in all copi 0270: 65 73 20 6f 72 20 73 75 62 73 74 61 6e 74 69 61 es or substantia 0280: 6c 20 70 6f 72 74 69 6f 6e 73 20 6f 66 20 74 68 l portions of th 0290: 65 20 53 6f 66 74 77 61 72 65 2e 0a 3b 3b 3b 20 e Software..;;; 02a0: 0a 3b 3b 3b 20 54 48 45 20 53 4f 46 54 57 41 52 .;;; THE SOFTWAR 02b0: 45 20 49 53 20 50 52 4f 56 49 44 45 44 20 22 41 E IS PROVIDED "A 02c0: 53 20 49 53 22 2c 20 57 49 54 48 4f 55 54 20 57 S IS", WITHOUT W 02d0: 41 52 52 41 4e 54 59 20 4f 46 20 41 4e 59 20 4b ARRANTY OF ANY K 02e0: 49 4e 44 2c 0a 3b 3b 3b 20 45 58 50 52 45 53 53 IND,.;;; EXPRESS 02f0: 20 4f 52 20 49 4d 50 4c 49 45 44 2c 20 49 4e 43 OR IMPLIED, INC 0300: 4c 55 44 49 4e 47 20 42 55 54 20 4e 4f 54 20 4c LUDING BUT NOT L 0310: 49 4d 49 54 45 44 20 54 4f 20 54 48 45 20 57 41 IMITED TO THE WA 0320: 52 52 41 4e 54 49 45 53 0a 3b 3b 3b 20 4f 46 20 RRANTIES.;;; OF 0330: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 2c MERCHANTABILITY, 0340: 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 50 FITNESS FOR A P 0350: 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f 53 ARTICULAR PURPOS 0360: 45 20 41 4e 44 0a 3b 3b 3b 20 4e 4f 4e 49 4e 46 E AND.;;; NONINF 0370: 52 49 4e 47 45 4d 45 4e 54 2e 20 49 4e 20 4e 4f RINGEMENT. IN NO 0380: 20 45 56 45 4e 54 20 53 48 41 4c 4c 20 54 48 45 EVENT SHALL THE 0390: 20 41 55 54 48 4f 52 53 20 4f 52 20 43 4f 50 59 AUTHORS OR COPY 03a0: 52 49 47 48 54 0a 3b 3b 3b 20 48 4f 4c 44 45 52 RIGHT.;;; HOLDER 03b0: 53 20 42 45 20 4c 49 41 42 4c 45 20 46 4f 52 20 S BE LIABLE FOR 03c0: 41 4e 59 20 43 4c 41 49 4d 2c 20 44 41 4d 41 47 ANY CLAIM, DAMAG 03d0: 45 53 20 4f 52 20 4f 54 48 45 52 20 4c 49 41 42 ES OR OTHER LIAB 03e0: 49 4c 49 54 59 2c 0a 3b 3b 3b 20 57 48 45 54 48 ILITY,.;;; WHETH 03f0: 45 52 20 49 4e 20 41 4e 20 41 43 54 49 4f 4e 20 ER IN AN ACTION 0400: 4f 46 20 43 4f 4e 54 52 41 43 54 2c 20 54 4f 52 OF CONTRACT, TOR 0410: 54 20 4f 52 20 4f 54 48 45 52 57 49 53 45 2c 20 T OR OTHERWISE, 0420: 41 52 49 53 49 4e 47 0a 3b 3b 3b 20 46 52 4f 4d ARISING.;;; FROM 0430: 2c 20 4f 55 54 20 4f 46 20 4f 52 20 49 4e 20 43 , OUT OF OR IN C 0440: 4f 4e 4e 45 43 54 49 4f 4e 20 57 49 54 48 20 54 ONNECTION WITH T 0450: 48 45 20 53 4f 46 54 57 41 52 45 20 4f 52 20 54 HE SOFTWARE OR T 0460: 48 45 20 55 53 45 20 4f 52 0a 3b 3b 3b 20 4f 54 HE USE OR.;;; OT 0470: 48 45 52 20 44 45 41 4c 49 4e 47 53 20 49 4e 20 HER DEALINGS IN 0480: 54 48 45 20 53 4f 46 54 57 41 52 45 2e 20 0a 0a THE SOFTWARE. .. 0490: 3b 3b 3b 20 54 68 65 20 64 65 66 61 75 6c 74 20 ;;; The default 04a0: 63 6f 6d 70 61 72 61 74 6f 72 0a 0a 3b 3b 3b 20 comparator..;;; 04b0: 53 74 61 6e 64 61 72 64 20 63 6f 6d 70 61 72 61 Standard compara 04c0: 74 6f 72 73 20 61 6e 64 20 74 68 65 69 72 20 66 tors and their f 04d0: 75 6e 63 74 69 6f 6e 73 0a 0a 3b 3b 20 54 68 65 unctions..;; The 04e0: 20 75 6e 6b 6e 6f 77 6e 2d 6f 62 6a 65 63 74 20 unknown-object 04f0: 63 6f 6d 70 61 72 61 74 6f 72 2c 20 75 73 65 64 comparator, used 0500: 20 61 73 20 61 20 66 61 6c 6c 62 61 63 6b 20 74 as a fallback t 0510: 6f 20 65 76 65 72 79 74 68 69 6e 67 20 65 6c 73 o everything els 0520: 65 0a 3b 3b 20 45 76 65 72 79 74 68 69 6e 67 20 e.;; Everything 0530: 63 6f 6d 70 61 72 65 73 20 65 78 61 63 74 6c 79 compares exactly 0540: 20 74 68 65 20 73 61 6d 65 20 61 6e 64 20 68 61 the same and ha 0550: 73 68 65 73 20 74 6f 20 30 0a 28 64 65 66 69 6e shes to 0.(defin 0560: 65 20 75 6e 6b 6e 6f 77 6e 2d 6f 62 6a 65 63 74 e unknown-object 0570: 2d 63 6f 6d 70 61 72 61 74 6f 72 0a 20 20 28 6d -comparator. (m 0580: 61 6b 65 2d 63 6f 6d 70 61 72 61 74 6f 72 0a 20 ake-comparator. 0590: 20 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 6a 29 (lambda (obj) 05a0: 20 23 74 29 0a 20 20 20 20 28 6c 61 6d 62 64 61 #t). (lambda 05b0: 20 28 61 20 62 29 20 23 74 29 0a 20 20 20 20 28 (a b) #t). ( 05c0: 6c 61 6d 62 64 61 20 28 61 20 62 29 20 23 66 29 lambda (a b) #f) 05d0: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 . (lambda (ob 05e0: 6a 29 20 30 29 29 29 0a 0a 3b 3b 20 4e 65 78 74 j) 0)))..;; Next 05f0: 20 69 6e 64 65 78 20 66 6f 72 20 61 64 64 65 64 index for added 0600: 20 63 6f 6d 70 61 72 61 74 6f 72 0a 0a 28 64 65 comparator..(de 0610: 66 69 6e 65 20 66 69 72 73 74 2d 63 6f 6d 70 61 fine first-compa 0620: 72 61 74 6f 72 2d 69 6e 64 65 78 20 39 29 0a 28 rator-index 9).( 0630: 64 65 66 69 6e 65 20 2a 6e 65 78 74 2d 63 6f 6d define *next-com 0640: 70 61 72 61 74 6f 72 2d 69 6e 64 65 78 2a 20 39 parator-index* 9 0650: 29 0a 28 64 65 66 69 6e 65 20 2a 72 65 67 69 73 ).(define *regis 0660: 74 65 72 65 64 2d 63 6f 6d 70 61 72 61 74 6f 72 tered-comparator 0670: 73 2a 20 28 6c 69 73 74 20 75 6e 6b 6e 6f 77 6e s* (list unknown 0680: 2d 6f 62 6a 65 63 74 2d 63 6f 6d 70 61 72 61 74 -object-comparat 0690: 6f 72 29 29 0a 0a 3b 3b 20 52 65 67 69 73 74 65 or))..;; Registe 06a0: 72 20 61 20 6e 65 77 20 63 6f 6d 70 61 72 61 74 r a new comparat 06b0: 6f 72 20 66 6f 72 20 75 73 65 20 62 79 20 74 68 or for use by th 06c0: 65 20 64 65 66 61 75 6c 74 20 63 6f 6d 70 61 72 e default compar 06d0: 61 74 6f 72 2e 0a 28 64 65 66 69 6e 65 20 28 63 ator..(define (c 06e0: 6f 6d 70 61 72 61 74 6f 72 2d 72 65 67 69 73 74 omparator-regist 06f0: 65 72 2d 64 65 66 61 75 6c 74 21 20 63 6f 6d 70 er-default! comp 0700: 61 72 61 74 6f 72 29 0a 20 20 28 73 65 74 21 20 arator). (set! 0710: 2a 72 65 67 69 73 74 65 72 65 64 2d 63 6f 6d 70 *registered-comp 0720: 61 72 61 74 6f 72 73 2a 20 28 63 6f 6e 73 20 63 arators* (cons c 0730: 6f 6d 70 61 72 61 74 6f 72 20 2a 72 65 67 69 73 omparator *regis 0740: 74 65 72 65 64 2d 63 6f 6d 70 61 72 61 74 6f 72 tered-comparator 0750: 73 2a 29 29 0a 20 20 28 73 65 74 21 20 2a 6e 65 s*)). (set! *ne 0760: 78 74 2d 63 6f 6d 70 61 72 61 74 6f 72 2d 69 6e xt-comparator-in 0770: 64 65 78 2a 20 28 2b 20 2a 6e 65 78 74 2d 63 6f dex* (+ *next-co 0780: 6d 70 61 72 61 74 6f 72 2d 69 6e 64 65 78 2a 20 mparator-index* 0790: 31 29 29 29 0a 0a 3b 3b 20 52 65 74 75 72 6e 20 1)))..;; Return 07a0: 6f 72 64 69 6e 61 6c 20 66 6f 72 20 6f 62 6a 65 ordinal for obje 07b0: 63 74 20 74 79 70 65 73 3a 20 6e 75 6c 6c 20 73 ct types: null s 07c0: 6f 72 74 73 20 62 65 66 6f 72 65 20 70 61 69 72 orts before pair 07d0: 73 2c 20 77 68 69 63 68 20 73 6f 72 74 0a 3b 3b s, which sort.;; 07e0: 20 62 65 66 6f 72 65 20 62 6f 6f 6c 65 61 6e 73 before booleans 07f0: 2c 20 65 74 63 2e 20 20 49 6d 70 6c 65 6d 65 6e , etc. Implemen 0800: 74 61 74 69 6f 6e 73 20 63 61 6e 20 65 78 74 65 tations can exte 0810: 6e 64 20 74 68 69 73 2e 0a 3b 3b 20 50 65 6f 70 nd this..;; Peop 0820: 6c 65 20 77 68 6f 20 63 61 6c 6c 20 63 6f 6d 70 le who call comp 0830: 61 72 61 74 6f 72 2d 72 65 67 69 73 74 65 72 2d arator-register- 0840: 64 65 66 61 75 6c 74 21 20 65 66 66 65 63 74 69 default! effecti 0850: 76 65 6c 79 20 64 6f 20 65 78 74 65 6e 64 20 69 vely do extend i 0860: 74 2e 0a 28 64 65 66 69 6e 65 20 28 6f 62 6a 65 t..(define (obje 0870: 63 74 2d 74 79 70 65 20 6f 62 6a 29 0a 20 20 28 ct-type obj). ( 0880: 63 6f 6e 64 0a 20 20 20 20 28 28 6e 75 6c 6c 3f cond. ((null? 0890: 20 6f 62 6a 29 20 30 29 0a 20 20 20 20 28 28 70 obj) 0). ((p 08a0: 61 69 72 3f 20 6f 62 6a 29 20 31 29 0a 20 20 20 air? obj) 1). 08b0: 20 28 28 62 6f 6f 6c 65 61 6e 3f 20 6f 62 6a 29 ((boolean? obj) 08c0: 20 32 29 0a 20 20 20 20 28 28 63 68 61 72 3f 20 2). ((char? 08d0: 6f 62 6a 29 20 33 29 0a 20 20 20 20 28 28 73 74 obj) 3). ((st 08e0: 72 69 6e 67 3f 20 6f 62 6a 29 20 34 29 0a 20 20 ring? obj) 4). 08f0: 20 20 28 28 73 79 6d 62 6f 6c 3f 20 6f 62 6a 29 ((symbol? obj) 0900: 20 35 29 0a 20 20 20 20 28 28 6e 75 6d 62 65 72 5). ((number 0910: 3f 20 6f 62 6a 29 20 36 29 0a 20 20 20 20 28 28 ? obj) 6). (( 0920: 76 65 63 74 6f 72 3f 20 6f 62 6a 29 20 37 29 0a vector? obj) 7). 0930: 20 20 20 20 28 28 62 79 74 65 76 65 63 74 6f 72 ((bytevector 0940: 3f 20 6f 62 6a 29 20 38 29 0a 20 20 20 20 3b 20 ? obj) 8). ; 0950: 41 64 64 20 6d 6f 72 65 20 68 65 72 65 20 69 66 Add more here if 0960: 20 79 6f 75 20 77 61 6e 74 3a 20 62 65 20 73 75 you want: be su 0970: 72 65 20 74 6f 20 75 70 64 61 74 65 20 63 6f 6d re to update com 0980: 70 61 72 61 74 6f 72 2d 69 6e 64 65 78 20 76 61 parator-index va 0990: 72 69 61 62 6c 65 73 0a 20 20 20 20 28 65 6c 73 riables. (els 09a0: 65 20 28 72 65 67 69 73 74 65 72 65 64 2d 69 6e e (registered-in 09b0: 64 65 78 20 6f 62 6a 29 29 29 29 0a 0a 3b 3b 20 dex obj))))..;; 09c0: 52 65 74 75 72 6e 20 74 68 65 20 69 6e 64 65 78 Return the index 09d0: 20 66 6f 72 20 74 68 65 20 72 65 67 69 73 74 65 for the registe 09e0: 72 65 64 20 74 79 70 65 20 6f 66 20 6f 62 6a 2e red type of obj. 09f0: 0a 28 64 65 66 69 6e 65 20 28 72 65 67 69 73 74 .(define (regist 0a00: 65 72 65 64 2d 69 6e 64 65 78 20 6f 62 6a 29 0a ered-index obj). 0a10: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 20 (let loop ((i 0a20: 30 29 20 28 72 65 67 69 73 74 72 79 20 2a 72 65 0) (registry *re 0a30: 67 69 73 74 65 72 65 64 2d 63 6f 6d 70 61 72 61 gistered-compara 0a40: 74 6f 72 73 2a 29 29 0a 20 20 20 20 28 63 6f 6e tors*)). (con 0a50: 64 0a 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 d. ((null? 0a60: 72 65 67 69 73 74 72 79 29 20 28 2b 20 66 69 72 registry) (+ fir 0a70: 73 74 2d 63 6f 6d 70 61 72 61 74 6f 72 2d 69 6e st-comparator-in 0a80: 64 65 78 20 69 29 29 0a 20 20 20 20 20 20 28 28 dex i)). (( 0a90: 63 6f 6d 70 61 72 61 74 6f 72 2d 74 65 73 74 2d comparator-test- 0aa0: 74 79 70 65 20 28 63 61 72 20 72 65 67 69 73 74 type (car regist 0ab0: 72 79 29 20 6f 62 6a 29 20 28 2b 20 66 69 72 73 ry) obj) (+ firs 0ac0: 74 2d 63 6f 6d 70 61 72 61 74 6f 72 2d 69 6e 64 t-comparator-ind 0ad0: 65 78 20 69 29 29 0a 20 20 20 20 20 20 28 65 6c ex i)). (el 0ae0: 73 65 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 29 se (loop (+ i 1) 0af0: 20 28 63 64 72 20 72 65 67 69 73 74 72 79 29 29 (cdr registry)) 0b00: 29 29 29 29 0a 0a 3b 3b 20 47 69 76 65 6e 20 61 ))))..;; Given a 0b10: 6e 20 69 6e 64 65 78 2c 20 72 65 74 72 69 65 76 n index, retriev 0b20: 65 20 61 20 72 65 67 69 73 74 65 72 65 64 20 63 e a registered c 0b30: 6f 6e 64 75 63 74 6f 72 2e 0a 3b 3b 20 49 6e 64 onductor..;; Ind 0b40: 65 78 20 6d 75 73 74 20 62 65 20 3e 3d 20 66 69 ex must be >= fi 0b50: 72 73 74 2d 63 6f 6d 70 61 72 61 74 6f 72 2d 69 rst-comparator-i 0b60: 6e 64 65 78 2e 0a 28 64 65 66 69 6e 65 20 28 72 ndex..(define (r 0b70: 65 67 69 73 74 65 72 65 64 2d 63 6f 6d 70 61 72 egistered-compar 0b80: 61 74 6f 72 20 69 29 0a 20 20 28 6c 69 73 74 2d ator i). (list- 0b90: 72 65 66 20 2a 72 65 67 69 73 74 65 72 65 64 2d ref *registered- 0ba0: 63 6f 6d 70 61 72 61 74 6f 72 73 2a 20 28 2d 20 comparators* (- 0bb0: 69 20 66 69 72 73 74 2d 63 6f 6d 70 61 72 61 74 i first-comparat 0bc0: 6f 72 2d 69 6e 64 65 78 29 29 29 0a 0a 28 64 65 or-index)))..(de 0bd0: 66 69 6e 65 20 28 64 69 73 70 61 74 63 68 2d 65 fine (dispatch-e 0be0: 71 75 61 6c 69 74 79 20 74 79 70 65 20 61 20 62 quality type a b 0bf0: 29 0a 20 20 28 63 61 73 65 20 74 79 70 65 0a 20 ). (case type. 0c00: 20 20 20 28 28 30 29 20 23 74 29 20 3b 20 41 6c ((0) #t) ; Al 0c10: 6c 20 65 6d 70 74 79 20 6c 69 73 74 73 20 61 72 l empty lists ar 0c20: 65 20 65 71 75 61 6c 0a 20 20 20 20 28 28 31 29 e equal. ((1) 0c30: 20 28 28 6d 61 6b 65 2d 70 61 69 72 3d 3f 20 28 ((make-pair=? ( 0c40: 6d 61 6b 65 2d 64 65 66 61 75 6c 74 2d 63 6f 6d make-default-com 0c50: 70 61 72 61 74 6f 72 29 20 28 6d 61 6b 65 2d 64 parator) (make-d 0c60: 65 66 61 75 6c 74 2d 63 6f 6d 70 61 72 61 74 6f efault-comparato 0c70: 72 29 29 20 61 20 62 29 29 0a 20 20 20 20 28 28 r)) a b)). (( 0c80: 32 29 20 28 62 6f 6f 6c 65 61 6e 3d 3f 20 61 20 2) (boolean=? a 0c90: 62 29 29 0a 20 20 20 20 28 28 33 29 20 28 63 68 b)). ((3) (ch 0ca0: 61 72 3d 3f 20 61 20 62 29 29 0a 20 20 20 20 28 ar=? a b)). ( 0cb0: 28 34 29 20 28 73 74 72 69 6e 67 3d 3f 20 61 20 (4) (string=? a 0cc0: 62 29 29 0a 20 20 20 20 28 28 35 29 20 28 73 79 b)). ((5) (sy 0cd0: 6d 62 6f 6c 3d 3f 20 61 20 62 29 29 0a 20 20 20 mbol=? a b)). 0ce0: 20 28 28 36 29 20 28 3d 20 61 20 62 29 29 0a 20 ((6) (= a b)). 0cf0: 20 20 20 28 28 37 29 20 28 28 6d 61 6b 65 2d 76 ((7) ((make-v 0d00: 65 63 74 6f 72 3d 3f 20 28 6d 61 6b 65 2d 64 65 ector=? (make-de 0d10: 66 61 75 6c 74 2d 63 6f 6d 70 61 72 61 74 6f 72 fault-comparator 0d20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 0d30: 20 20 20 20 20 20 20 20 20 20 20 76 65 63 74 6f vecto 0d40: 72 3f 20 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 r? vector-length 0d50: 20 76 65 63 74 6f 72 2d 72 65 66 29 20 61 20 62 vector-ref) a b 0d60: 29 29 0a 20 20 20 20 28 28 38 29 20 28 28 6d 61 )). ((8) ((ma 0d70: 6b 65 2d 76 65 63 74 6f 72 3d 3f 20 28 6d 61 6b ke-vector=? (mak 0d80: 65 2d 63 6f 6d 70 61 72 61 74 6f 72 20 65 78 61 e-comparator exa 0d90: 63 74 2d 69 6e 74 65 67 65 72 3f 20 3d 20 3c 20 ct-integer? = < 0da0: 64 65 66 61 75 6c 74 2d 68 61 73 68 29 0a 20 20 default-hash). 0db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0dc0: 20 20 20 20 20 20 20 62 79 74 65 76 65 63 74 6f bytevecto 0dd0: 72 3f 20 62 79 74 65 76 65 63 74 6f 72 2d 6c 65 r? bytevector-le 0de0: 6e 67 74 68 20 62 79 74 65 76 65 63 74 6f 72 2d ngth bytevector- 0df0: 75 38 2d 72 65 66 29 20 61 20 62 29 29 0a 20 20 u8-ref) a b)). 0e00: 20 20 3b 20 41 64 64 20 6d 6f 72 65 20 68 65 72 ; Add more her 0e10: 65 0a 20 20 20 20 28 65 6c 73 65 20 28 62 69 6e e. (else (bin 0e20: 61 72 79 3d 3f 20 28 72 65 67 69 73 74 65 72 65 ary=? (registere 0e30: 64 2d 63 6f 6d 70 61 72 61 74 6f 72 20 74 79 70 d-comparator typ 0e40: 65 29 20 61 20 62 29 29 29 29 0a 0a 28 64 65 66 e) a b))))..(def 0e50: 69 6e 65 20 28 64 69 73 70 61 74 63 68 2d 6f 72 ine (dispatch-or 0e60: 64 65 72 69 6e 67 20 74 79 70 65 20 61 20 62 29 dering type a b) 0e70: 0a 20 20 28 63 61 73 65 20 74 79 70 65 0a 20 20 . (case type. 0e80: 20 20 28 28 30 29 20 30 29 20 3b 20 41 6c 6c 20 ((0) 0) ; All 0e90: 65 6d 70 74 79 20 6c 69 73 74 73 20 61 72 65 20 empty lists are 0ea0: 65 71 75 61 6c 0a 20 20 20 20 28 28 31 29 20 28 equal. ((1) ( 0eb0: 28 6d 61 6b 65 2d 70 61 69 72 3c 3f 20 28 6d 61 (make-pair<? (ma 0ec0: 6b 65 2d 64 65 66 61 75 6c 74 2d 63 6f 6d 70 61 ke-default-compa 0ed0: 72 61 74 6f 72 29 20 28 6d 61 6b 65 2d 64 65 66 rator) (make-def 0ee0: 61 75 6c 74 2d 63 6f 6d 70 61 72 61 74 6f 72 29 ault-comparator) 0ef0: 29 20 61 20 62 29 29 0a 20 20 20 20 28 28 32 29 ) a b)). ((2) 0f00: 20 28 62 6f 6f 6c 65 61 6e 3c 3f 20 61 20 62 29 (boolean<? a b) 0f10: 29 0a 20 20 20 20 28 28 33 29 20 28 63 68 61 72 ). ((3) (char 0f20: 3c 3f 20 61 20 62 29 29 0a 20 20 20 20 28 28 34 <? a b)). ((4 0f30: 29 20 28 73 74 72 69 6e 67 3c 3f 20 61 20 62 29 ) (string<? a b) 0f40: 29 0a 20 20 20 20 28 28 35 29 20 28 73 79 6d 62 ). ((5) (symb 0f50: 6f 6c 3c 3f 20 61 20 62 29 29 0a 20 20 20 20 28 ol<? a b)). ( 0f60: 28 36 29 20 28 63 6f 6d 70 6c 65 78 3c 3f 20 61 (6) (complex<? a 0f70: 20 62 29 29 0a 20 20 20 20 28 28 37 29 20 28 28 b)). ((7) (( 0f80: 6d 61 6b 65 2d 76 65 63 74 6f 72 3c 3f 20 28 6d make-vector<? (m 0f90: 61 6b 65 2d 64 65 66 61 75 6c 74 2d 63 6f 6d 70 ake-default-comp 0fa0: 61 72 61 74 6f 72 29 20 76 65 63 74 6f 72 3f 20 arator) vector? 0fb0: 76 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 76 65 vector-length ve 0fc0: 63 74 6f 72 2d 72 65 66 29 20 61 20 62 29 29 0a ctor-ref) a b)). 0fd0: 20 20 20 20 28 28 38 29 20 28 28 6d 61 6b 65 2d ((8) ((make- 0fe0: 76 65 63 74 6f 72 3c 3f 20 28 6d 61 6b 65 2d 63 vector<? (make-c 0ff0: 6f 6d 70 61 72 61 74 6f 72 20 65 78 61 63 74 2d omparator exact- 1000: 69 6e 74 65 67 65 72 3f 20 3d 20 3c 20 64 65 66 integer? = < def 1010: 61 75 6c 74 2d 68 61 73 68 29 0a 09 09 09 20 62 ault-hash).... b 1020: 79 74 65 76 65 63 74 6f 72 3f 20 62 79 74 65 76 ytevector? bytev 1030: 65 63 74 6f 72 2d 6c 65 6e 67 74 68 20 62 79 74 ector-length byt 1040: 65 76 65 63 74 6f 72 2d 75 38 2d 72 65 66 29 20 evector-u8-ref) 1050: 61 20 62 29 29 0a 20 20 20 20 3b 20 41 64 64 20 a b)). ; Add 1060: 6d 6f 72 65 20 68 65 72 65 0a 20 20 20 20 28 65 more here. (e 1070: 6c 73 65 20 28 62 69 6e 61 72 79 3c 3f 20 28 72 lse (binary<? (r 1080: 65 67 69 73 74 65 72 65 64 2d 63 6f 6d 70 61 72 egistered-compar 1090: 61 74 6f 72 20 74 79 70 65 29 20 61 20 62 29 29 ator type) a b)) 10a0: 29 29 0a 0a 3b 3b 3b 20 54 68 65 20 61 75 74 68 ))..;;; The auth 10b0: 6f 72 20 6f 66 20 53 52 46 49 20 31 32 38 20 68 or of SRFI 128 h 10c0: 61 73 20 73 75 67 67 65 73 74 65 64 20 61 20 70 as suggested a p 10d0: 6f 73 74 2d 66 69 6e 61 6c 69 7a 61 74 69 6f 6e ost-finalization 10e0: 20 6e 6f 74 65 0a 3b 3b 3b 20 73 61 79 69 6e 67 note.;;; saying 10f0: 20 74 68 65 20 66 69 72 73 74 20 61 6e 64 20 74 the first and t 1100: 68 69 72 64 20 62 75 6c 6c 65 74 20 69 74 65 6d hird bullet item 1110: 73 20 73 74 61 74 69 6e 67 20 22 6d 75 73 74 22 s stating "must" 1120: 20 72 65 71 75 69 72 65 6d 65 6e 74 73 0a 3b 3b requirements.;; 1130: 3b 20 66 6f 72 20 64 65 66 61 75 6c 74 2d 68 61 ; for default-ha 1140: 73 68 20 6d 61 79 20 62 65 20 77 65 61 6b 65 6e sh may be weaken 1150: 65 64 2e 20 20 54 68 61 74 20 61 6c 6c 6f 77 73 ed. That allows 1160: 20 61 20 6d 75 63 68 20 66 61 73 74 65 72 20 68 a much faster h 1170: 61 73 68 0a 3b 3b 3b 20 66 75 6e 63 74 69 6f 6e ash.;;; function 1180: 20 74 6f 20 62 65 20 75 73 65 64 20 66 6f 72 20 to be used for 1190: 6c 69 73 74 73 20 61 6e 64 20 76 65 63 74 6f 72 lists and vector 11a0: 73 2e 0a 0a 28 64 65 66 69 6e 65 20 28 64 65 66 s...(define (def 11b0: 61 75 6c 74 2d 68 61 73 68 20 6f 62 6a 29 0a 20 ault-hash obj). 11c0: 20 28 63 61 73 65 20 28 6f 62 6a 65 63 74 2d 74 (case (object-t 11d0: 79 70 65 20 6f 62 6a 29 0a 20 20 20 20 28 28 30 ype obj). ((0 11e0: 20 31 20 37 29 20 3b 20 65 6d 70 74 79 20 6c 69 1 7) ; empty li 11f0: 73 74 2c 20 70 61 69 72 2c 20 6f 72 20 76 65 63 st, pair, or vec 1200: 74 6f 72 0a 20 20 20 20 20 28 28 6d 61 6b 65 2d tor. ((make- 1210: 68 61 73 68 65 72 29 20 28 65 71 75 61 6c 2d 68 hasher) (equal-h 1220: 61 73 68 20 6f 62 6a 29 29 29 0a 20 20 20 20 28 ash obj))). ( 1230: 28 32 29 20 28 62 6f 6f 6c 65 61 6e 2d 68 61 73 (2) (boolean-has 1240: 68 20 6f 62 6a 29 29 0a 20 20 20 20 28 28 33 29 h obj)). ((3) 1250: 20 28 63 68 61 72 2d 68 61 73 68 20 6f 62 6a 29 (char-hash obj) 1260: 29 0a 20 20 20 20 28 28 34 29 20 28 73 74 72 69 ). ((4) (stri 1270: 6e 67 2d 68 61 73 68 20 6f 62 6a 29 29 0a 20 20 ng-hash obj)). 1280: 20 20 28 28 35 29 20 28 73 79 6d 62 6f 6c 2d 68 ((5) (symbol-h 1290: 61 73 68 20 6f 62 6a 29 29 0a 20 20 20 20 28 28 ash obj)). (( 12a0: 36 29 20 28 6e 75 6d 62 65 72 2d 68 61 73 68 20 6) (number-hash 12b0: 6f 62 6a 29 29 0a 20 20 20 20 28 28 38 29 20 28 obj)). ((8) ( 12c0: 28 6d 61 6b 65 2d 76 65 63 74 6f 72 2d 68 61 73 (make-vector-has 12d0: 68 20 28 6d 61 6b 65 2d 64 65 66 61 75 6c 74 2d h (make-default- 12e0: 63 6f 6d 70 61 72 61 74 6f 72 29 0a 20 20 20 20 comparator). 12f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 1300: 20 20 20 20 20 20 20 20 20 62 79 74 65 76 65 63 bytevec 1310: 74 6f 72 3f 20 62 79 74 65 76 65 63 74 6f 72 2d tor? bytevector- 1320: 6c 65 6e 67 74 68 20 62 79 74 65 76 65 63 74 6f length bytevecto 1330: 72 2d 75 38 2d 72 65 66 29 20 6f 62 6a 29 29 0a r-u8-ref) obj)). 1340: 20 20 20 20 3b 20 41 64 64 20 6d 6f 72 65 20 68 ; Add more h 1350: 65 72 65 0a 20 20 20 20 28 65 6c 73 65 20 28 63 ere. (else (c 1360: 6f 6d 70 61 72 61 74 6f 72 2d 68 61 73 68 20 28 omparator-hash ( 1370: 72 65 67 69 73 74 65 72 65 64 2d 63 6f 6d 70 61 registered-compa 1380: 72 61 74 6f 72 20 28 6f 62 6a 65 63 74 2d 74 79 rator (object-ty 1390: 70 65 20 6f 62 6a 29 29 20 6f 62 6a 29 29 29 29 pe obj)) obj)))) 13a0: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 64 65 66 . .(define (def 13b0: 61 75 6c 74 2d 6f 72 64 65 72 69 6e 67 20 61 20 ault-ordering a 13c0: 62 29 0a 20 20 28 6c 65 74 20 28 28 61 2d 74 79 b). (let ((a-ty 13d0: 70 65 20 28 6f 62 6a 65 63 74 2d 74 79 70 65 20 pe (object-type 13e0: 61 29 29 0a 20 20 20 20 20 20 20 20 28 62 2d 74 a)). (b-t 13f0: 79 70 65 20 28 6f 62 6a 65 63 74 2d 74 79 70 65 ype (object-type 1400: 20 62 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a b))). (cond. 1410: 20 20 20 20 20 20 28 28 3c 20 61 2d 74 79 70 65 ((< a-type 1420: 20 62 2d 74 79 70 65 29 20 23 74 29 0a 20 20 20 b-type) #t). 1430: 20 20 20 28 28 3e 20 61 2d 74 79 70 65 20 62 2d ((> a-type b- 1440: 74 79 70 65 29 20 23 66 29 0a 20 20 20 20 20 20 type) #f). 1450: 28 65 6c 73 65 20 28 64 69 73 70 61 74 63 68 2d (else (dispatch- 1460: 6f 72 64 65 72 69 6e 67 20 61 2d 74 79 70 65 20 ordering a-type 1470: 61 20 62 29 29 29 29 29 0a 0a 28 64 65 66 69 6e a b)))))..(defin 1480: 65 20 28 64 65 66 61 75 6c 74 2d 65 71 75 61 6c e (default-equal 1490: 69 74 79 20 61 20 62 29 0a 20 20 28 6c 65 74 20 ity a b). (let 14a0: 28 28 61 2d 74 79 70 65 20 28 6f 62 6a 65 63 74 ((a-type (object 14b0: 2d 74 79 70 65 20 61 29 29 0a 20 20 20 20 20 20 -type a)). 14c0: 20 20 28 62 2d 74 79 70 65 20 28 6f 62 6a 65 63 (b-type (objec 14d0: 74 2d 74 79 70 65 20 62 29 29 29 0a 20 20 20 20 t-type b))). 14e0: 28 69 66 20 28 3d 20 61 2d 74 79 70 65 20 62 2d (if (= a-type b- 14f0: 74 79 70 65 29 20 28 64 69 73 70 61 74 63 68 2d type) (dispatch- 1500: 65 71 75 61 6c 69 74 79 20 61 2d 74 79 70 65 20 equality a-type 1510: 61 20 62 29 20 23 66 29 29 29 0a 0a 28 64 65 66 a b) #f)))..(def 1520: 69 6e 65 20 28 6d 61 6b 65 2d 64 65 66 61 75 6c ine (make-defaul 1530: 74 2d 63 6f 6d 70 61 72 61 74 6f 72 29 0a 20 20 t-comparator). 1540: 28 6d 61 6b 65 2d 63 6f 6d 70 61 72 61 74 6f 72 (make-comparator 1550: 0a 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6f 62 . (lambda (ob 1560: 6a 29 20 23 74 29 0a 20 20 20 20 64 65 66 61 75 j) #t). defau 1570: 6c 74 2d 65 71 75 61 6c 69 74 79 0a 20 20 20 20 lt-equality. 1580: 64 65 66 61 75 6c 74 2d 6f 72 64 65 72 69 6e 67 default-ordering 1590: 0a 20 20 20 20 64 65 66 61 75 6c 74 2d 68 61 73 . default-has 15a0: 68 29 29 0a 0a h))..